اذهب الي المحتوي
أوفيسنا

نجوم المشاركات

  1. Ali Mohamed Ali

    Ali Mohamed Ali

    المشرفين السابقين


    • نقاط

      109

    • Posts

      11,597


  2. kkhalifa1960

    kkhalifa1960

    الخبراء


    • نقاط

      104

    • Posts

      712


  3. ابوخليل

    ابوخليل

    أوفيسنا


    • نقاط

      64

    • Posts

      10,627


  4. Mohamed Hicham

    Mohamed Hicham

    الخبراء


    • نقاط

      63

    • Posts

      545


Popular Content

Showing content with the highest reputation since 01 ماي, 2023 in all areas

  1. احببت ان افرد موضوعي هذا بعنوان مستقل 1-لان غالب او جميع الدروس هنا تتعامل مع واتساب ويندوز 2-وحتى يكون تطوير هذا العمل مستقلا ولا يحدث خلط بين الامثلة المثال المرفق تم تطبيقه على واتساب ويب واليكم بعض التوجيهات والملاحظات : كانت مشكلتي في محاولات سابقة انه في كل مرة يتم الارسال وفتح الواتساب ويب .. فانه يطلب ربطا جديدا بالجوال وبحمد الله توصلت الى حل هذه المشكلة التي كانت عائقا حقيقيا .. يكتفى بالارتباط مرة واحدة فقط الآن : عند كل ارسال يفتح الواتس ويب بشاشة جديدة .. فان كانت هناك نسخة مفتوحة من قبل فانه يتجاهلها وتصبح غير فعالة وهذه لا مشكلة فيها لأنه يفتح على الحساب نفسه . ارجوا من اخوتي واحبتي الذين يمرون من هنا تجربة المثال وافادتي بنتيجة التجربة ، من اجل الانتقال الى الخطوة التالية وهي ارسال المرفقات sendwatsWeb.mdb
    6 points
  2. وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ربما هدا طلبك . تقسيم البيانات كل اسبوع في ورقة مستقلة مع انشاء مجلد في القرص (E) وحفظ الملفات بداخله بصيغة (PDF) مع تنسيق الجداول بنفس التنسيق المرفق في طلبك . Public Sub Split_Sheet_condition_of_the_week() Dim dataSheet As Worksheet, weekSheet As Worksheet Dim minDate As Date, maxDate, weekStartDate As Date Dim lr As Long, c As Long, LastRow As Long, MH As Variant Dim weekSheetName As String, WS_Address As String Dim ST_DATA, ST_Name, ST_Path, ST_WS_Data As String Dim WS_Data As Range, Total_Rng As Range Dim wsData As Worksheet: Set wsData = Worksheets("تجميع") 'حدف جميع اوراق العمل باستثناء ورقة التجميع Application.ScreenUpdating = False For Each ws In Worksheets If ws.Name <> "تجميع" Then Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If Next Set dataSheet = wsData With dataSheet lr = .Cells(.Rows.Count, "F").End(xlUp).Row 'اصغر تاريخ minDate = Application.WorksheetFunction.Min(.Range("F2:F" & lr)) ' اكبر تاريخ maxDate = Application.WorksheetFunction.Max(.Range("F2:F" & lr)) End With weekStartDate = Date_Prev_Saturday(minDate) While weekStartDate <= maxDate 'تسمية الشيتات weekSheetName = Format(weekStartDate, "d") & " To " & Format(weekStartDate + 6, "d") With ActiveWorkbook Set weekSheet = Nothing On Error Resume Next Set weekSheet = .Worksheets(weekSheetName) On Error GoTo 0 If weekSheet Is Nothing Then 'اظافة وتسمية اوراق العمل Set weekSheet = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count)) weekSheet.Name = weekSheetName weekSheet.DisplayRightToLeft = True Else weekSheet.Cells.Clear End If End With 'فلترة البيانات weekSheet.Range("l1:m1").Value = Array(dataSheet.Range("F1").Value, dataSheet.Range("F1").Value) weekSheet.Range("l2:m2").Value = Array(">=" & CLng(weekStartDate), "<=" & CLng(weekStartDate) + 6) dataSheet.Range("F1:k" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=weekSheet.Range("l1:m2"), CopyToRange:=weekSheet.Range("A4"), Unique:=False weekSheet.Range("l1:m2").Clear weekSheet.Columns("A:F").EntireColumn.ColumnWidth = 16 LastRow = weekSheet.Cells.SpecialCells(xlCellTypeLastCell).Row Set Total_Rng = Range(weekSheet.Cells(LastRow + 1, "A"), weekSheet.Cells(LastRow + 1, "F")) MH = (RGB(153, 153, 255)) ' اظافة المعادلات weekSheet.Range("F5").Formula = "=COUNTIF(تجميع!$f$2:$f$500,a5)" weekSheet.Range("F5").AutoFill Destination:=Range("F5:F" & LastRow) weekSheet.Range("E5:E" & LastRow) = "=sum(B5*D5)" Cells(LastRow + 1, 1).Value = "المجموع" For c = 2 To 6 Cells(LastRow + 1, c).Value = Application.Sum(Range(Cells(5, c), Cells(LastRow, c))) Next c 'تنسيق الجدول Total_Rng.Interior.Color = MH Total_Rng.Font.Bold = True Total_Rng.Font.Size = 13 With Range("A5:F" & LastRow + 1) .HorizontalAlignment = xlCenter .Font.Name = "Calibri" .Font.Size = 16 .Value = .Value End With 'تسطير الجدول DL = weekSheet.Range("A65500").End(xlUp).Row DC = weekSheet.Cells(5, Columns.Count).End(xlToLeft).Column Range(weekSheet.Cells(5, 1), weekSheet.Cells(DL, DC)).Borders.Weight = xlThin 'فواصل الصفحات With weekSheet.Range("A5:A" & _ weekSheet.Range("A" & Rows.Count).End(xlUp).Row) Set WS_Data = weekSheet.Cells.Find(What:="المجموع", LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlNext) If Not WS_Data Is Nothing Then WS_Address = WS_Data.Address Do If Not WS_Data Is Nothing Then WS_Data.Offset(1).PageBreak = xlPageBreakManual End If Set WS_Data = .FindNext(WS_Data) If WS_Data Is Nothing Then Exit Do End If If WS_Data.Address = WS_Address Then Exit Do End If Loop End If End With On Error Resume Next ActiveWindow.View = xlPageBreakPreview weekSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 ActiveWindow.View = xlNormalView ' إنشاء مجلد الحفظ ST_Name = "فرز البيانات الأسبوعية" ST_DATA = "" ST_WS_Data = "E:\" ' قم بتغييره بما يناسبك 'ST_WS_Data = "D:\" If IsEmpty(ST_Name) Then Exit Sub If IsEmpty(ST_DATA) Then Exit Sub MkDir ST_WS_Data & "\" & ST_Name ST_Path = ST_WS_Data & "\" & ST_Name & "\" & ST_DATA ' مسار وضع الشيتات بصيغة (PDF)""""""""""""""""""""""""""""" مسار مجلد الحفظ weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="E:\فرز البيانات الأسبوعية\" & weekSheet.Name & "_" & Format(Now, "MMMM") & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=False weekStartDate = weekStartDate + 7 Wend dataSheet.Select MsgBox "" & ST_WS_Data & ST_Name & vbLf & vbLf & vbLf & "من :" & " " & Format(minDate, "dd/mm/yyyy") & vbLf & vbLf & "إلى :" & " " & Format(maxDate, "dd/mm/yyyy") & " " & _ FolderName, _ vbInformation, " : تم حفظ الملفات بنجاح في " On Error GoTo 0 Application.ScreenUpdating = True End Sub Private Function Date_Prev_Saturday(fromDate As Date) As Date Date_Prev_Saturday = fromDate - Weekday(fromDate) + vbSaturday + 7 * (vbSaturday > Weekday(fromDate)) End Function بالتوفيق.......... تجميع V1.xlsm
    6 points
  3. تفضل هذا بمعادلة مصفوفة (Ctrl+Shift+Enter) Report Between Two Dates.xlsb
    6 points
  4. السلام عليكم و رحمة الله استخدم الكود التالى Sub GetData() Dim Sh As Worksheet, ws As Worksheet Dim LR As Long, Countr As Long, p As Long Dim Arr(), Fsl As String, C As Range, j As Long Set Sh = Sheets("saad") Sh.Range("C14:T1000") = "" Fsl = Sh.Range("R12") For Each ws In Worksheets If ws.Name <> Sh.Name Then LR = ws.Range("C" & Rows.Count).End(3).Row Countr = Countr + LR End If Next ReDim Preserve Arr(Countr, 18) For Each ws In Worksheets If ws.Name <> Sh.Name Then For Each C In ws.Range("C10:C" & LR) If C.Offset(0, 15).Value = Fsl Then p = p + 1 For j = 0 To 17 Arr(p - 1, j) = C.Offset(0, j) Arr(p - 1, 0) = p Next End If Next End If Next If p > 0 Then Sh.Range("C14").Resize(p, UBound(Arr, 2)).Value = Arr End Sub
    5 points
  5. وعليمن السلام بالإذن خيار آخر Sub test() Dim a, b: Dim lr& a = ActiveSheet.Range("D6:D14").Resize(, 4) ReDim b(1 To 5) b = Array(1, 3, 5, 7, 9) Workbooks.Open ("C:\Users\Ehab Elhady\Desktop\1.xlsx") With Sheets("sheet1").Cells(1, 1).Resize(, 5) lr = .Cells(Rows.Count, 1).End(xlUp).Row .Offset(lr).Value = Application.Index(a, b, 1) .Offset(lr, 5).Value = Application.Index(a, b, 4) End With Workbooks("1.xlsx").Close True End Sub
    5 points
  6. تفضل اخي هدا حل اخر على حسب ما فهمت من اخر ملف قمت برفعه تمت اظافة شيت جديد باسم النتائج لاستخراج تقرير كل اسبوع على حده تحت بعض في ورقة واحدة كما في الصورة ادناه . شيت النتائج مع استخراج بيانات كل اسبوع في شيت مستقل بدون تكرار للتواريخ . وحفظ الكل في مجلد في بارتشن (E) فرز بيانات V2.rar
    5 points
  7. بالاذن من الاستاذ Lionheart بنفس الطريقة Sub test1() Dim a Dim r As Range Dim frA Dim x& With Sheets(1) a = Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Cells End With x = 1 With Sheets("ÇáÌÏæá") Set r = Range("B:B").Find("ÇáÑÞã", , , , 1) frA = r.Address If Not r Is Nothing Then Do r.Offset(1).Resize(10) = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + 10 & ")"), 1), "") x = x + 10 Set r = .Range("B:B").FindNext(r) Loop Until frA = r.Address End If End With End Sub وخيار آخر يعتمد على عدد الاسطر وافراغات التي يجب أن تكون متساوية في كل الشيت Sub test2() Dim a Dim r As Range Dim frA Dim x&, i&, ii& With Sheets(1) a = Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Cells End With x = 1 With Sheets("الجدول") For i = 1 To UBound(a) Step 10 .Cells(4 + ii * 20, 2).Select .Cells(4 + ii * 20, 2).Resize(10) = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + 10 & ")"), 1), "") x = x + 10 ii = ii + 1 Next End With End Sub المرفق مع الخيارين sabah.xlsm
    5 points
  8. مشاركة مع الخبير @kanory مجرد افكار لا اكثر نمارس هواية البرمجة مع بعض التأملات خذ بعض الافكار الي اضفتها لبرنامجك - اضفت لك جدول و في داخله كلمة مرور - عشان تعرض السطور المخفية راح يطلب منك كلمة مرور طبعا هي نفسها الي في الجدول 1234 بسيطة جدا اشكرا على المتابعة - تقدر تحتفظ باختيارك في عرض الصفوف و اخفائها للمرة القادة في زيارتك الميمونة - خطاباتك اذا برنامج ما حصل الخطاب في الفولدر راح يعطيك رسالة تنبيه رايقة جدا بدون تخويف اتمنى تعجبك الفكرة مجرة افكار خلال لحظات تأمل و اشكرك و اشكر كل من قرأ بتأمل و اعطاني وقته الثمين برنامج متابعة.zip
    5 points
  9. لقد حاولت وبفضل الله نجح الامر معي والشكر لجميع أعضاء المنتدى الشكر موصول للأخ Lionhear Option Explicit Sub Get_Data_From_Closed_Workbooks() Dim a, wb As Workbook, ws As Worksheet, sFile As String, sPath As String, lr As Long, m, x, y, z As Long Application.ScreenUpdating = False sPath = ThisWorkbook.Path & "\" & "تقارير" & "\" sFile = Dir(sPath & [k6] & "*" & ".xlsx") m = 9 With Sheet12.Range("b8").CurrentRegion.Offset(1) .ClearContents: .Borders.Value = 0 End With Do While sFile <> "" Set wb = Workbooks.Open(sPath & sFile, ReadOnly:=True) Set ws = wb.Sheets(1) With ws lr = .Cells(Rows.Count, "b").End(xlUp).Row a = .Range("b9:o" & lr).Value x = [c6] y = [e6] z = [h6] .Parent.Close False End With Sheet12.Range("b" & m).Resize(UBound(a, 1), UBound(a, 2)).Value = a m = m + UBound(a, 1) sFile = Dir() Loop With Sheet12.Range("b9:o" & m - 1) .Borders.Value = 1 End With [c6] = x [e6] = y [h6] = z End Sub
    5 points
  10. بعدد إذن الاخ كريم وإثرائا للموضوع جرب هذا البرنامج ABBYY Fine Reader أستخدمه منذ فترة وكان يأتي على اسطوانة التعريفات مع بعض الماسحات الضوئية والميزة يسمح بالتصدير الى صيغ متنوعة وأيضا يسمح بالتحويل من الماسح الضوئي أو ماكينة التصوير مباشرة ممتاز جدا يحول الانجليزي بكفاءة عالية جدا مع أخطاء لا تكاد تذكر ويحول العربي أيضا لكن قد يختلف بعض التنسيقات ولكن قد يحدث خطأ في بعض الصور في الملف
    5 points
  11. وعليكم السلام معادله مقدار الدرجات =IF(F4="","",VLOOKUP(F4,'بيانات المعلمين'!$A$2:$K$212,10,0)) =IF(F5="","",VLOOKUP(F5,'بيانات المعلمين'!$A$2:$K$212,10,0)) معادله الملاحظات =IF(F4="","",VLOOKUP(F4,'بيانات المعلمين'!$A$2:$K$212,9,0)) =IF(F5="","",VLOOKUP(F5,'بيانات المعلمين'!$A$2:$K$212,9,0)) تجربة 1.xls
    5 points
  12. وعليكم السلام -يمكنك استخدام هذه المعادلة =IFERROR(INDEX(ورقة1!B2:B270,MATCH(0,COUNTIF($A$1:A1,ورقة1!B2:B270),0)),"") تلخيص1.xlsx
    4 points
  13. اليك حل اخر Sub CopyData() Dim x, y(), i&, lr&, ws_rng2&, ws_rng3& Set ws_rng = Sheet1 lr = ws_rng.Range("A" & Rows.Count).End(xlUp).Row x = ws_rng.Range("A2:B" & lr) For i = 1 To UBound(x, 1) If x(i, 2) <> 0 Then ws_rng3 = ws_rng3 + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To ws_rng3) For ws_rng2 = 1 To UBound(x, 2) y(ws_rng2, ws_rng3) = x(i, ws_rng2) Next End If Next ws_rng.Range("k2").Resize(ws_rng3, UBound(y, 1)) = Application.Transpose(y) End Sub آسف لم انتبه لمسألة تعدد أوراق العمل لعدم وجودها على الملف المرفق سوف أقوم باظافتها لاحقا. فقط لاثراء الموضوع لا أكثر.فحل الأستاذ @محي الدين ابو البشر يوفي بالغرض ورقة عمل جديد.xlsm
    4 points
  14. موعدنا اليوم مع تطبيق ضمن سلسلة ما خف وزنه وغلا ثمنه لأحبابي أعضاء وزوار منتدى أوفيسنا تطبيق يساعدك في إنشاء رسائل msgbox بصورة احترافية فقط اختر الأزرار والعنوان ونص الرسالة والأيقونة وباقي الخيارات ثم اضغط على زر تجربة لمشاهدة كود الرسالة ثم قم بنسخ الكود لبرنامجك ويمكنك استخدام الثوابت والقيم في كتابة الكود وفي الأخير لا ينقصني سوى دعاؤكم msgboxbuilder.rar
    4 points
  15. حسب الصورة عسى Sub Test() Dim i& For i = 2 To Range("A" & Rows.Count).End(xlUp).Row If Cells(i, 1).Interior.Color = vbYellow Then Cells(Range("B" & Rows.Count).End(xlUp).Row + 1, 2).Value = Cells(i, 1).Value Next End Sub Book1.xlsm
    4 points
  16. عليكم السلام عسى رصيد لكل مادة حسب المخزن.xlsx
    4 points
  17. وعليكم السلام-ياريت تقوم بتغيير عنوان المشاركة ليصبح ( معادلة IF متعددة الشروط) وهذه المعادلة تفى بالغرض وشكراً =IF(AND($C4<>"غ",$B4="ذكر"),"ناجح",IF(AND($C4<>"غ",$B4="أنثي"),"ناجحة",IF(AND($C4="غ",$B4="ذكر"),"ناجح بحكم القانون",IF(AND($C4="غ",$B4="أنثي"),"ناجحة بحكم القانون","")))) معادلة IF.xlsx
    4 points
  18. وعليكم السلام-تفضل هذه المعادلة تخص اللون الأخضر =COUNTIFS($G$5:$G$700,">=9",$G$5:$G$700,"<=10") أما اللون الأحمر فيكفيك هذه المعادلة ...وشكراً =COUNTIF($G$5:$G$700,"<=4") فرق بين تاريخين.xlsx
    4 points
  19. تفضل هذه الفكرة بناء جدول تلقائي من خلال الكود بناء على بيانات الجدول test.accdb
    4 points
  20. اصدقائي الاكارم السلام عليكم و رحمة الله و بركاته تحية طيبة يمكن عن طريق المثال التالي انشاء كود QR يدعم اللغة العربية اولا ننسخ المجلد interop(vba) الى المجلد C:\Windows ثم نشغل الملف register.cmd كمسؤول ثم نستخدم المرفق للحصول على كود QR انشاء كود QR.rar
    4 points
  21. تفضل اخي الكريم New Microsoft Excel Worksheet.xlsx.rar
    4 points
  22. أول مرة أفهم عليك أيش تقول 😂 على أية حال أخي @ابو عبد الرحمن اشرف .. لو كنت تقصد أنه لو عطبت نسخة الجداول BE وأردت إعادة الربط بالنخة الاحتياطية .. فأنت تحتاج في هذه الحالة لكود البحث عن نسخة ال BE وإعادة ربطها بنسخة الواجهة .. وهناك عدة أفكار لذلك .. وفي الرابط التالي ستجد فكرتين .. واحدة لأستاذنا جعفر والأخرى للعبد الفقير .. لكيفية تخزين عناوين قواعد البيانات الخلفية ثم إعادة الربط بها حسب حاجة المبرمج :
    4 points
  23. السلام عليكم و رحمة الله و بركاته اصدقائي الاكارم تحية طيبة في هذا التطبيق سنقوم بتحويل قاعدة بيانات اكسس الى SQL Server طبعا قد يعتبر البعض الموضوع قديم نوعا ما و لكن في هذا التطبيق تم التجريب على ويندوز 11 و اوفيس 2021 32بت و SQL 2005 نسخة مخصصة للعمل على ويندوز 11 قبل البدء لا ننسى ان نقوم باخذ نسخة احتياطية من قاعدة بيانات اكسس و اضافة المكتبات الموضحة في الصورة الى قاعدة البيانات ملاحظة : مكتبة microsoft office 16 object library موجودة في المسار "C:\Program Files (x86) \ Microsoft Office \ root \ vfs \ ProgramFilesCommonX86 \ Microsoft Shared \ OFFICE16\MSO.dll" برنامج SQL Server برنامج إدارة قواعد بيانات SQL برنامج ترحيل قواعد بيانات اكسس الى SQL Server الجزء الاول.pdf 1.bmp
    4 points
  24. تفضل التعديل راح يضيف نفس الاسم اذا ما وجده ضمن القائمة الاعجمة Replace (1).accdb
    4 points
  25. لم افهم عليك بالنسبة للطلب الاول .... اذا تم اخفائها فيتم اخفائها في النموذج الرئيسي والفرعي معا ..... وعند الاظهار يظهرها جميعا دفعة واحد ... هل هذا هو المطلوب ؟؟؟؟؟ اما المطلوب الثاني .... فستخدم هذا الكود .... Dim X$ Dim dirr As String Dim i As String i = Nz(Me.k_code, 0) dirr = CurrentProject.Path & "\files\" & i & ".tif" X$ = Dir$(dirr) If X$ = "" Then MsgBox "It does Not exist!", vbExclamation, "Doesn't Exist" Else ShellExecute Me.hwnd, "open", dirr, "", "", 1 End If
    4 points
  26. وعليكم السلام لا يمكن فتح أى ملف اكسيل يحتوى على أكواد VBA على الموبيل وشكراً !
    4 points
  27. وعليكم السلام .. لابد ان يكون هناك ملف اكسيل بأى مشاركة لتدعيمها وتوضيح المطلوب بكل دقة وذلك تجنباً لإهدار الوقت !! ولكن عليك بوضع هذا الكود بحدث ThisworkBook حتى يتم تنفيذ طلبك Private Sub Workbook_Open() Worksheets("Main").Activate Range("D5").Select End Sub وهناك كود أخر بالملف المرفوع لك للإنتقال الى خلية معينة من الصفحة الأخرى وسيكون ذلك بمديول عادى Example.xlsm
    4 points
  28. 4 points
  29. بما انك لم تقم بالاجابة سوف احاول وضع جميع الاحتمالات الواردة بخصوص السؤال الاول يمكنك اختيار ما يناسبك ووضعه في حدث الشيت ''تنبيه عند تكرار نفس القيمة في العمود اكثر من 10 مرات Private Sub Worksheet_Change(ByVal Target As Range) With Target ' تحديد رقم العمود الهدف If (.Column <> 3) Or .Cells.Count > 10 Then Exit Sub ' تحديد اقصى عدد للتكرار المسموح به If WorksheetFunction.CountIf(Columns(.Column), .Value) > 10 Then 'حدف القيمة المدخلة .ClearContents MsgBox "لايمكن طباعة أكثر من 10", vbMsgBoxRight + vbOKOnly, "لا يمكن الاستمرار" End If End With End Sub ''''''''''''''''''''''''''''' Private Sub Worksheet_Change(ByVal Target As Range) ' تنبيه عند تجاوز عدد القيم على العمود 10 قيم Dim ws As Worksheet Set ws = Sheet1 Dim LastRow As Long Application.ScreenUpdating = False LastRow = ws.Range("C65000").End(xlUp).Row DataCount = Application.WorksheetFunction.CountA(ws.Range("C:C")) ' تجديد عدد القيم المسموح بها If DataCount > 10 Then MsgBox "لايمكن طباعة أكثر من 10", vbMsgBoxRight + vbOKOnly, "لا يمكن الاستمرار" 'حدف القيمة المدخلة ws.Cells(Rows.Count, "c").End(xlUp).ClearContents End If End Sub اما بخصوص السؤال الثاني Sub test1() ' تلوين المجموعات في النطاق المطلوب اينما وجد التكرار ' قم بظبط الاعدادات بما يناسبك Const FirstRow As Long = 2 ' اول صف Const FirstColumn As String = "C" 'اول عمود Const LastColumn As String = "F" ' اخر عمود Dim dict As Object Dim Ky As Variant Dim rng As Range Dim Arr As Variant Dim Rl As Long Dim Cols As Variant Dim Idx As Long Dim Sp() As String Dim c As Long Dim R As Long 'أضف العديد من الألوان كما يحلو لك Cols = Array(65535, 10086143, 16763904, 15123099, 9359529, 11854022, 32896, 65280, 16711680, 65535, 16711935, _ 16763904, 13434828, 16764057, _ 13408767, 16751052, 10079487) Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") With Worksheets("Sheet1") ' اسم الورقة الخاص بك ' حدف التنسيقات السابقة Columns("C:F").Interior.Pattern = xlNone For c = Columns(FirstColumn).Column To Columns(LastColumn).Column Rl = .Cells(.Rows.Count, c).End(xlUp).Row If Rl >= FirstRow Then Set rng = .Range(.Cells(1, c), .Cells(Rl, c)) Arr = rng.Value For R = FirstRow To Rl If Len(Arr(R, 1)) Then ' تسجيل عنوان كل خلية غير فارغة حسب القيمة dict(Arr(R, 1)) = dict(Arr(R, 1)) & "," & _ Cells(R, c).Address End If Next R End If Next c For Each Ky In dict Sp = Split(dict(Ky), ",") ' شرط عدد التكرار لتنفيد الامر If UBound(Sp) > 1 Then ' تطبيق نفس اللون على نفس القيم For c = 1 To UBound(Sp) .Range(Sp(c)).Interior.Color = Cols(Idx) Next c Idx = Idx + 1 ' إعادة تدوير الألوان إذا كانت غير كافية If Idx > UBound(Cols) Then Idx = LBound(Cols) End If Next Ky End With Application.ScreenUpdating = True End Sub ''''''''''''''''''''''''''''''''''''''''' '("C") تلوين المجموعات بشرط تكرارها في عمود Sub test2() Dim ws As Worksheet Dim cell As Range Dim myrng As Range Dim clr As Long Dim lastCell As Range Set ws = ThisWorkbook.Sheets("Sheet1") 'النطاق الهدف Set myrng = ws.Range("c2:f" & Range("c" & ws.Rows.Count).End(xlUp).Row) ' نطاق الشرط Set myrng2 = ws.Range("c2:c" & Range("c" & ws.Rows.Count).End(xlUp).Row) With myrng Set lastCell = .Cells(.Cells.Count) End With myrng.Interior.ColorIndex = xlNone clr = 3 For Each cell In myrng If Application.WorksheetFunction.CountIf(myrng2, cell) > 1 Then If myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Address = cell.Address Then cell.Interior.ColorIndex = clr clr = clr + 1 Else cell.Interior.ColorIndex = myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Interior.ColorIndex End If End If Next End Sub ولاستخراج القيم وعدد تكرارها يمكنك استخدام الكود التالي Sub test3() ' عدد القيم المكررة Dim rng As Range Dim var As Variant Dim i As Integer Dim ws As Worksheet Set ws = Sheet1 lr = Range("C65536").End(xlUp).Row Set myrng = ws.Range("M1:N" & Range("c" & ws.Rows.Count).End(xlUp).Row) Application.ScreenUpdating = False myrng.clear ws.[M1] = "القيم" ws.[N1] = "عدد التكرار" i = 0 Set d = CreateObject("Scripting.Dictionary") For Each rng In ws.Range("c2:f" & lr) If rng <> "" Then If d.exists(rng.Value) Then d(rng.Value) = d(rng.Value) + 1 Else d.Add rng.Value, 1 End If End If Next For Each var In d.keys '(M) سيتم وضع الاسماء في العمود '(N)وعدد تكرارها في العمود Range("M" & (i + 2)) = var Range("N" & (i + 2)) = d(var) i = i + 1 Next myrng.Borders.Weight = xlThin Range("N2:N" & lr).Font.Color = 255 Set d = Nothing Application.ScreenUpdating = True End Sub واليك الملف عليه جميع الاكواد اختر ما يناسبك بالتوفيق countif_V2.xlsm countif_V3.xlsm
    4 points
  30. عليكم السلام ورحمة الله وبركاته ما رأيك بكود Sub test() Dim a Dim i&, ii& Dim sh As Worksheet For Each sh In Worksheets ii = 1 a = sh.Cells(1).CurrentRegion ReDim b(1 To UBound(a), 1 To UBound(a, 2)) For i = 2 To UBound(a) If a(i, 2) <> "" Then b(ii, 1) = a(i, 1): b(ii, 2) = a(i, 2) ii = ii + 1 End If Next sh.Cells(2, 11).Resize(ii, 2) = b Next End Sub ورقة عمل Microsoft Excel جديد (2).xlsm
    3 points
  31. تفضل جرب Private Sub TextBox26_Change() Dim CelF As Range, LigF As Long Set ws = ActiveWorkbook.Sheets("Data") With ws Set lst = ws.ListObjects("الجدول1") If lst.ShowAutoFilter Then lst.ShowAutoFilter = False End If Set CelF = ws.Range("Find").Find(What:=Me.TextBox26, LookIn:=xlValues, LookAt:=xlWhole, _ SearchDirection:=xlNext, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False) If Not CelF Is Nothing Then LigF = CelF.Row Label1.Caption = ws.Range("B" & LigF) Label2.Caption = ws.Range("C" & LigF) Label3.Caption = ws.Range("E" & LigF) Label4.Caption = ws.Range("D" & LigF) Else For S = 1 To 3 Me("Label" & S) = Empty Next S End If End With Label2 = Format(Label2, "dd/mm/yyyy") Label2.BackColor = &H8000000F End Sub TEST V1.xlsb
    3 points
  32. السلام عليكم و رحمة الله شاهد هذا المرفق ربما يكون هو طلبك يمكنك التعديل عليه بما يتوافق مع رغباتك ViewPicts.rar
    3 points
  33. Insert Module1 and paste the following code Option Explicit Private Sub ColorBySubject() Const STARTROW As Long = 8, STARTCOL As Long = 5, COLSNUM As Long = 4 Dim x, aCols, wsMarks As Worksheet, wsColors As Worksheet, rng As Range, sMarks As String, sQuote As String, sCell As String, n As Long, m As Long, ii As Long Application.ScreenUpdating = False With ThisWorkbook Set wsMarks = .Worksheets(1) Set wsColors = .Worksheets(2) End With Set rng = wsColors.Range("S8:S15") x = Application.Match(wsColors.Range("E3").Value, rng, 0) If Not IsError(x) Then sMarks = wsMarks.Name sQuote = WorksheetFunction.Rept(Chr(34), 2) n = wsMarks.Cells(Rows.Count, "C").End(xlUp).Row - 3 aCols = Array(5, 8, 11, 14, 17, 20, 23, 26) For m = 1 To 3 sCell = ColumnToLetter(aCols(x - 1) + m - 1) & "4" With wsColors If m <> 3 Then For ii = 4 To 1 Step -1 With .Cells(STARTROW, m * COLSNUM - ii + STARTCOL).Resize(n) .Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & "=" & ii & ",""0""," & sQuote & "))" End With Next ii Else With .Cells(STARTROW, 13).Resize(n) .Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & ">=3.5,""0""," & sQuote & "))" .Offset(, 1).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(AND(" & sMarks & "!" & sCell & ">=2.5," & sMarks & "!" & sCell & "<3.5),""0""," & sQuote & "))" .Offset(, 2).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(AND(" & sMarks & "!" & sCell & ">1," & sMarks & "!" & sCell & "<2.5),""0""," & sQuote & "))" .Offset(, 3).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & "=1,""0""," & sQuote & "))" End With End If End With Next m End If Application.ScreenUpdating = True End Sub Function ColumnToLetter(ByVal columnNumber As Long) As String If columnNumber < 1 Then Exit Function ColumnToLetter = UCase(ColumnToLetter(Int((columnNumber - 1) / 26)) & Chr(((columnNumber - 1) Mod 26) + Asc("A"))) End Function Then in worksheet module (Colors) [The worksheet that has the data validation list], paste the following code Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Address = "$E$3" Then Application.Run "Module1.ColorBySubject" End If End Sub
    3 points
  34. تفضل استاذ @أغيد طلبك في التقرير (Report1). ولا تنسى طلبي . تحويل صفوف الجدول الى اعمدة -1.accdb
    3 points
  35. جرب المرفق .. تمت كتابة المعادلة بواسطة الذكاء الاصطناعي 🙂 الوقت.xls
    3 points
  36. عذراً خطأ طباعي Book1.xlsm
    3 points
  37. وعليكم السلام ورحمه الله وبركاته For Each w In ThisWorkbook.Worksheets If w.Name <> "ورقة7" And w.Name <> "ورقة8" Then co1.AddItem w.Name End If Next w
    3 points
  38. تفضل طلبك و لا تنساني بدعوة طيبة مثال.accdb
    3 points
  39. السلام عليكم ورحمه الله وبركاته وبها نبدأ تفضل ضع هذا الكود في حدث الشيت المطلوب Private Sub Worksheet_Change(ByVal Target As Range) Dim X As Range Application.EnableEvents = False For Each X In Target If X.Row > 3 Then If X.Column = 2 Then If X.Value = "ok" Then X.Offset(0, -1).Value = Date ElseIf X.Column = 3 Then If X.Offset(0, -1).Value = "ok" Then X.Offset(0, 1).Value = X End If End If Next X Application.EnableEvents = True End Sub
    3 points
  40. Try this code Sub Test() Const NROWS As Long = 10 Dim a, ws As Worksheet, sh As Worksheet, r As Range, s As String, m As Long, i As Long With ThisWorkbook Set ws = .Worksheets(1): Set sh = .Worksheets(2) End With s = Join(Array(Chr(199), Chr(225), Chr(209), Chr(222), Chr(227)), Empty) m = 2 Set r = sh.Columns(2) a = FindNext(s, r) If Not IsEmpty(a) Then For i = LBound(a) To UBound(a) With sh.Range("A" & a(i)).CurrentRegion.Offset(1) .ClearContents: .Borders.Value = 0 End With sh.Range("A" & a(i) + 1).Resize(NROWS).Value = Evaluate("ROW(1:" & NROWS & ")") sh.Range("B" & a(i) + 1).Resize(NROWS).Value = ws.Range("A" & m).Resize(NROWS).Value m = m + NROWS Next i End If End Sub Function FindNext(ByVal strFind As String, ByVal rng As Range) Dim arr(), myRng As Range, iRow As Long, k As Long With rng Set myRng = .Find(What:=strFind, After:=rng.Cells(rng.Cells.Count), LookIn:=xlValues, LookAt:=xlPart) If Not myRng Is Nothing Then iRow = myRng.Row Do k = k + 1 ReDim Preserve arr(1 To k) arr(k) = myRng.Row Set myRng = .FindNext(myRng) Loop Until myRng.Row = iRow End If End With FindNext = arr End Function Note the following The code will find the rows that has the string `NUMBER` then to copy 10 numbers from the first worksheet and so on But the code is limited to the headers in the second worksheet so not all the numbers in the first worksheet will be copied
    3 points
  41. الأصدقاء الاكارم السلام عليكم و رحمة الله و بركاته اعتقد ان الموضوع قديم نوعا ما و لكن الكل يعاني من مربعات الحوار حفظ و فتح ملف ( و انا واحد منهم 😅) الحل موجود هنا 🙂 OpenSaveFileDialog.rar
    3 points
  42. وعليكم السلام ورحمة الله وبركاته .. 🙂 نعم ممكن أخي @moho58 بكل سهولة .. وبدون الحاجة للدخول في تعقيدات الاستعلام الجدولي .. مادام أن الشكل ثابت لا يتغير بزيادة في عدد السجلات المعروضة .. وإنما التغيير يكون أسبوعيا .. فيمكنك إنشاء جدول وتكون الحقول هي نفس عدد الخلايا التي في الشكل الذي عندك لكل سجل .. هكذا : وبعدها سيكون الموضوع بسيط جدا .. مجرد تنسيق للخلايا في النموذج هكذا : والنتيجة النهائية في النموذج : ولو أردت جعل المادة والمعلم تظهر تلقائيا بدل كتابتها كل مرة .. ضعها في خاصية القيمة الافتراضية عند تصميم الجدول الملف المرفق : جدول أسبوعي.accdb
    3 points
  43. تفضل لازم تحدد الحقل الي لما تضغط على رقم 1 يكتب داخل الحقل رقم 1 و كذلك لبقية الارقام و فوق الارقام حطيت لك مربح يبين الحقل المحدد اتمنى تناسبك الفكرة alizaeyd.accdb
    3 points
  44. تم اكمال المثال حسب الأمر بالتسلسل واكتفيت بالصور والمستندات فقط آمل من اخواني التجربة وارسال مرفق لأكثر من شخص ، والافادة بالنتيجة لتفادي المشكلات ان وجدت واعتماده كما اطلب من اخوتي الخبراء فحص الزمن ( sleep) وضبطه ان لزم حتى تظهر عملية الارسال انسيابية محكمة .. لانه حاليا ومن مشاهدتي يوجد تفاوت في السرعة والبطء خلال تنقل الأمر sendwatsWeb2.mdb
    3 points
  45. التعامل مع الاستعلام الجدولي محدود .. لذا يصعب تطبيق فصل الجمع على مستوى افقي انظر كيفية الفصل في المثال .. اصبح لكل منتج سطر حسب السنة نستطيع القول انهما استعلامان ضمن استعلام واحد تستفيد من توظيفه جيدا في التقرير اذا تم العرض حسب المنتج بمعنى الاستعلام عن منتج محدد خلال السنتين على مستوى المحافظات ايضا يمكن جلب القيم منه الى خلايا غير منضمة بمعلومية ( السنة / المحافظة / المنتج ) مثال اوفيسنا اجمالي المبيعات الشهرية3.mdb
    3 points
  46. لمشاهدة كيفية استخدام البرنامج اضعط على الرابط
    3 points
  47. تفضل أخي برنامج حصلته عندي من أعمال منتدانا أفسينا الاستبيان---2003.rar
    3 points
  48. البرنامج كما ذكرت لك
    3 points
  49. تعمل فولدر وليكن (icons) ثم تعبئ به كل الأيكونات التي تريدها تجيبها من جوجل بامتداد (ico.) أو (.bmp) وبعطيك برنامج يصنع أيكونات فقط افلت أي صورة حتى صورتك . واحفظها بالفولدر الذي أنشأته . ثم تستدعي الأيكون من فورم الأكسس عادي . ولو مش عارف كيف نشرح . المهم تقرأ البرنامج وين طريقة الحفظ . واليك البرنامج ووافني بالرد . ToYcon.rar
    3 points
  50. وعليكم السلام ورحمة الله وبركاته إليك هذا الملف يمكن يفيدك إن شاء الله الفكرة قريبة من كشوف مناداة اللجان في الاختبارات وهذا يمكن طباعته يدويا ويمكن اضافة كود لطباعة الكل تلقائيا مناداة ولجان لجنة.xls
    3 points
×
×
  • اضف...

Important Information