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

@محمد هشام. برجاء من كل الاخوة الكرام الي كل من يعرف الاخ محمد هشام او لا يعرفه الي كل من ساعده الاخ محمد هشام او لم يساعده ان يدعو له من كل قلبه و بخالص الدعوات ان يشقي ابنه الغالي واتمنى من الادمن المحترم انه يثبت البوست لفترة وشكرا علي قبول البوست

السلام عليكم اخى محمد نعم اريد حذف ملفات الاكسيل ذات الامتداد .xlsb من دريف معين حاول كتابة الكود وسنرى مع التجربة كيف نتلافى البطء ان شاء الله

مشاركة مع اخي جعفر نصيحة مجرب : ريح راسك واكتب العناوين عادية في التقرير .. اقوى وأحكم الصورة ندرجها عادة من اجل اطار متميز .. او خلفية خاصة .. ولكنها حرة لا علاقة لها بالبيانات

Option Explicit Option Compare Text Sub FilterContractorData() Dim CrWS As Worksheet, dest As Worksheet, c As Long, OnRng, ColArr, a(1 To 4) Const tmp1 = 3, tmp2 = 4, colDate = 1 Dim col As Range, dataRng As Range, lastCol As Long: lastCol = 25 Set CrWS = Sheets("يومية المقاولين") Set dest = Sheets("تقرير تفصيلى") Dim lastRow As Long: lastRow = dest.Rows.Count With Application .ScreenUpdating = False: .Calculation = xlCalculationManual With dest .Range("A11:Y" & lastRow).ClearContents .Range("A11:Y" & lastRow).Borders.LineStyle = xlNone End With OnRng = CrWS.Range("B8:Y" & CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row).Value a(1) = dest.[D3].Value: a(2) = dest.[E3].Value a(3) = dest.[C6].Value: a(4) = dest.[D6].Value ColArr = FiltreTbl(OnRng, a, tmp1, tmp2, colDate, _ Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24)) If Not IsEmpty(ColArr) Then dest.Range("B11").Resize(UBound(ColArr), UBound(ColArr, 2)).Value = ColArr With dest.Range("A11:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-10") End With Call ShFormat(dest, "A:Y") Set dataRng = dest.Range("A11:Y" & lastRow) For c = 1 To lastCol If Application.WorksheetFunction.CountA(dest.Range(dest.Cells(11, c), dest.Cells(lastRow, c))) = 0 Then dest.Columns(c).Hidden = True Else dest.Columns(c).Hidden = False End If Next c Else MsgBox "لا توجد بيانات تطابق الشروط المحددة", vbExclamation End If .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub v3-عمالة نظام 2025_2026.xlsm

أكرمك الله أستاذنا الكبير النتيجة رائعة ومضبوطة 100 % كده انتهى الموضوع على أكمل وجه واكتمل تماما والله أستاذنا منذ أكثر من عام وأنا أبحث في هذا الموضوع وتلك الفكرة الحمد لله رب العالمين تفوقت على نفسك أستاذنا وصغت الحل بسلاسة وسرعة ودقة متناهية كل التقدير والشكر لسعادتك وجزاكم الله كل الخير ؛؛؛

ادن لنجرب طريقة أخرى Option Explicit Sub Testxlsb() Dim xPath As String, n As Double Dim startTime As Double, xList As String Dim sCount As Long, confirm As VbMsgBoxResult xPath = "D:\" xList = "" With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual startTime = Timer tmps xPath, xList If xList = "" Then MsgBox "لم يتم العثور على أي ملفات بامتداد xlsb في " & xPath Else sCount = UBound(Split(Trim(xList), vbCrLf)) confirm = MsgBox("تم العثور على " & sCount & " ملف بامتداد xlsb " & vbCrLf & _ "هل تريد حدفها ونقلها إلى مجلد الملفات المحدوفة ؟", vbYesNo + vbQuestion) If confirm = vbYes Then tbl xPath, xList Snames xList MsgBox "تم الحذف وحفظ أسماء الملفات في C:\الملفات المحدوفة\filName.txt" Else MsgBox "تم إلغاء العملية لم يتم حذف أي ملفات" End If End If .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With n = Timer - startTime MsgBox "تم تنفيذ العملية في: " & Format(n, "0.00") & " ثانية" End Sub Sub tmps(ByVal xPath As String, ByRef xList As String) Dim fso As Object, Folder As Object, file As Object, sFiles As Object Set fso = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set Folder = fso.GetFolder(xPath) If Folder Is Nothing Then Exit Sub On Error GoTo 0 If Not Folder Is Nothing Then On Error Resume Next For Each file In Folder.Files If (file.Attributes And 2) = 0 And (file.Attributes And 4) = 0 Then If LCase(fso.GetExtensionName(file.Name)) = "xlsb" Then xList = xList & file.Path & vbCrLf End If End If Next On Error GoTo 0 On Error Resume Next For Each sFiles In Folder.sFiless tmps sFiles.Path, xList Next On Error GoTo 0 End If End Sub Sub tbl(ByVal xPath As String, ByRef xList As String) Dim fso As Object, Folder As Object, file As Object, sFiles As Object Dim CntFile As String, r As String, ky As Integer CntFile = "C:\الملفات المحدوفة\DeletedXLSB\" Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FolderExists("C:\الملفات المحدوفة\") Then fso.CreateFolder ("C:\الملفات المحدوفة\") If Not fso.FolderExists(CntFile) Then fso.CreateFolder (CntFile) On Error Resume Next Set Folder = fso.GetFolder(xPath) If Folder Is Nothing Then Exit Sub On Error GoTo 0 On Error Resume Next For Each file In Folder.Files If Err.Number = 0 Then If (file.Attributes And 2) = 0 And (file.Attributes And 4) = 0 Then If LCase(fso.GetExtensionName(file.Name)) = "xlsb" Then r = CntFile & fso.GetFileName(file.Path) ky = 1 While fso.FileExists(r) r = CntFile & "Copy_" & ky & "_" & fso.GetFileName(file.Path) ky = ky + 1 Wend file.Move r End If End If End If Err.Clear Next For Each sFiles In Folder.sFiless tbl sFiles.Path, xList Next On Error GoTo 0 End Sub Sub Snames(xList As String) Dim fileNum As Integer fileNum = FreeFile On Error Resume Next Open "C:\الملفات المحدوفة\filName.txt" For Output As #fileNum Print #fileNum, xList Close #fileNum On Error GoTo 0 End Sub TEST2.xlsm

أخي أحمد ، جرب هذا التعديل الجديد من حيث الدقة والتوافق بين الشفهي واللياقة ؛ حيث تم اضافة حقلين في جدول اللياقة ( رقم الصف ، وملاحظات ) في المرفق التالي :- فكرة توزيع تلقائي لمستويين (3).mdb

بالنسبة للعربية انظر الصورة لتعديل اسماء التسمية التوضيحية للحقول بالنسبة للعدالة طبعا تقريبية اضف الحقل SupervisionCount في الجدول Teachers نمواصفت ( رقم - القيمة الافتراضية 0 ) ثم استخدم الكود التالي في زر التوزيع Dim db As DAO.Database Dim rsA As DAO.Recordset, rsB As DAO.Recordset Dim rsRooms As DAO.Recordset, rsDays As DAO.Recordset, rsTarget As DAO.Recordset Dim supervisionDate As Date, roomName As String Set db = CurrentDb() ' ? تمهيد: مسح الجدول وتصفير العدادات db.Execute "UPDATE Teachers SET SupervisionCount = 0" db.Execute "DELETE FROM TeacherAssignment" Set rsDays = db.OpenRecordset("SELECT * FROM SupervisionDays ORDER BY SupervisionDate", dbOpenDynaset) Set rsRooms = db.OpenRecordset("SELECT * FROM ExamRooms ORDER BY RoomName", dbOpenDynaset) Set rsTarget = db.OpenRecordset("TeacherAssignment") ' ? تحقق من توفر عدد كافٍ من المعلمين Dim totalSupervisionsNeeded As Long Dim availableA As Long, availableB As Long totalSupervisionsNeeded = DCount("*", "SupervisionDays") * DCount("*", "ExamRooms") availableA = DCount("*", "Teachers", "TeacherCategory = 'A' AND (ExamDate Is Null OR ExamDate Not In (SELECT SupervisionDate FROM SupervisionDays)) AND (CorrectionCommittee Is Null OR CorrectionCommittee = '')") availableB = DCount("*", "Teachers", "TeacherCategory = 'B' AND (ExamDate Is Null OR ExamDate Not In (SELECT SupervisionDate FROM SupervisionDays)) AND (CorrectionCommittee Is Null OR CorrectionCommittee = '')") If availableA < totalSupervisionsNeeded Or availableB < totalSupervisionsNeeded Then Dim response As VbMsgBoxResult response = MsgBox("عدد المعلمين المتاحين قد لا يكون كافياً لتغطية جميع القاعات في جميع الأيام." & vbCrLf & _ "هل ترغب في المتابعة مع ذلك؟", vbYesNo + vbQuestion, "تأكيد التوزيع") If response = vbNo Then MsgBox "تم إلغاء عملية التوزيع بناءً على طلب المستخدم.", vbInformation Exit Sub End If End If ' ?? بدء التوزيع Dim usedA As Collection: Set usedA = New Collection Dim usedB As Collection: Set usedB = New Collection Do While Not rsDays.EOF supervisionDate = rsDays!supervisionDate rsRooms.MoveFirst Do While Not rsRooms.EOF roomName = rsRooms!roomName ' معلم فئة A Set rsA = db.OpenRecordset("SELECT * FROM Teachers WHERE TeacherCategory='A' AND (CorrectionCommittee Is Null OR CorrectionCommittee='') ORDER BY SupervisionCount ASC", dbOpenSnapshot) rsA.MoveFirst Do While Not rsA.EOF If Not InCollection(usedA, rsA!TeacherName & "#" & supervisionDate) And (IsNull(rsA!ExamDate) Or rsA!ExamDate <> supervisionDate) Then rsTarget.AddNew rsTarget!TeacherName = rsA!TeacherName rsTarget!TeacherCategory = rsA!TeacherCategory rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update On Error Resume Next usedA.Add rsA!TeacherName, rsA!TeacherName & "#" & supervisionDate Err.Clear: On Error GoTo 0 db.Execute "UPDATE Teachers SET SupervisionCount = SupervisionCount + 1 WHERE TeacherName = '" & rsA!TeacherName & "'" Exit Do End If rsA.MoveNext Loop ' معلم فئة B Set rsB = db.OpenRecordset("SELECT * FROM Teachers WHERE TeacherCategory='B' AND (CorrectionCommittee Is Null OR CorrectionCommittee='') ORDER BY SupervisionCount ASC", dbOpenSnapshot) rsB.MoveFirst Do While Not rsB.EOF If Not InCollection(usedB, rsB!TeacherName & "#" & supervisionDate) And (IsNull(rsB!ExamDate) Or rsB!ExamDate <> supervisionDate) Then rsTarget.AddNew rsTarget!TeacherName = rsB!TeacherName rsTarget!TeacherCategory = rsB!TeacherCategory rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update On Error Resume Next usedB.Add rsB!TeacherName, rsB!TeacherName & "#" & supervisionDate Err.Clear: On Error GoTo 0 db.Execute "UPDATE Teachers SET SupervisionCount = SupervisionCount + 1 WHERE TeacherName = '" & rsB!TeacherName & "'" Exit Do End If rsB.MoveNext Loop rsRooms.MoveNext Loop rsDays.MoveNext Loop rsTarget.Close: rsA.Close: rsB.Close: rsRooms.Close: rsDays.Close Set rsTarget = Nothing: Set rsA = Nothing: Set rsB = Nothing Set rsRooms = Nothing: Set rsDays = Nothing: Set db = Nothing MsgBox "تم توزيع المعلمين بعد تحقق العدالة وشروط الاستبعاد!"

وعليكم السلام ورحمة الله تعالى وبركاته هل تقصد حدف الملفات ادا كان كدالك فالكود قد يستغرق وقتا طويلا وقد يجمد Excel أحيانا خاصة عند البحث داخل درايف كامل (مثلD) يحتوي على آلاف الملفات والمجلدات الأفضل تحديد مجلد معين داخل بارتيشن معين سيكون افضل واسرع

شكرا جزيلا أخي الفاضل

كلام من ذهب اتفق معاك اخوي ابوخليل 100% ، وخصوصا عندنا امكانبة اختيار انواع الخطوط واحجامها في التقرير

وعليكم السلام مشاهدة التقرير في عرض التصميم يختلف عن معاينة الطباعة ، حيث ان معاينة الطباعة تكون مربوطة باعدادات الطابعة. 1. يجب ان لا يظهر لك المثلث الاخضر في الزاوية التي فيها الدائرة الزرقاء ، والتي تشير الى ان عرض تقريرك اكبر من عرض الورقة التي استعملتها في اعدادات الصفحة (a4 في حالتك) ، وعرض التقرير هو الصفحة التي تشاهدها امامك + الهامش الايمن + الهامش الايسر. بمعنى آخر ، اعمل تصغير للتقرير الى ان يختفي المثلث الاخضر. 2. يجب ان تعمل محاذاة للحقل (محاذاة اليمين مثلا) ، ثم تقول بتضيط مكانه ، وبعد الاحيان المحاذاة تختلف في وضع التصميم عن وضع الطباعة ، فتقوم بتحريك الحقل حتى يكون مضبوط في وضع الطباعة . واجعل الصورة بمحاذاة اليسار ، فهي تكون ثابتة في العرض والطباعة

الحمدلله 🙂 ورجاء العمل على المادة 3 من مقترحي ، حتى يصبح تقريرك خفيف على البرنامج وسريع الاستجابة. اهلا اخي طاهر 🙂 1. نعم بالتأكيد ، الافضل حذف الصورة المتضمنة في التقرير واستبدالها بحقول ومسميات ، نعم قد تحتاج الى بعض اجزاء الصورة المتضمنة ، مثل الشعار او التوقيع ، ولكن يجب ان يكون طول وعرض الصورة لا يكون اكبر من الواقع ، مثلا عرض صفحة A4 هو 21 سنتيمتر ، والشعار في منتصف الصفحة طوله حوالي 7 سنتيمتر ، فعليه ، اعمل هذا الشعار بهذه المقاسات ، يعني مو تجيبها من السكانر بدقة 1200x1200 dpi ثم تضعها في التقرير مباشرة دون تعديل 😱 2. نعم يوجد كود لإستيراد الصفحة من من ملف pdf وتحويلها الى صورة (انا استعمل برنامج www.irfanview.net ليقوم به برمجيا عن طريق command line ) ، ولكن الموضوع سيكون اصعب.

الأخ الفاضل @kkhalifa1960 والأخ الفاضل @jjafferr جزاكم الله كل الخير على الرد والاهتمام بموضوعي كلتا الاجابتين تؤديان المطلوب اجابة الأخ @kkhalifa1960 فيها بعض التوسعة والاضافات الجيدة مرة أخرى من القلب أصدق عبارات الشكر والإمتنان و جزاكما الله خيرا و ربي يبارك في هذا المنتدى الرائع ان شاء الله

بالنسبة لاسماء الاعمدة . نعم ممكن تعديلها الى العربية .. سوف اشرح لك حال توفر جهاز حاسب لاني اكتب من الجوال ما المقصود بالعدالة؟ أن يحصل كل معلم على عدد أيام مراقبة متقارب قدر الإمكان. ألا يُكرر معلم في أكثر من يوم قبل استخدام باقي المعلمين. أن يُوزع العبء بالتساوي بين الفئتين A و B.

وعليكم السلام اضف مربع النص هذا (تقدر تعمله مخفي)، في هذا القسم: ثم في حدث عند تنسيق Report Footer اكتب هذا الكود Private Sub Report_Footer_Format(Cancel As Integer, FormatCount As Integer) On Error GoTo err_Report_Footer_Format Me.p = DLookup("Page_lettre", "tab_Page", "num_page=" & Me.Pages) Exit_Report_Footer_Format: Exit Sub err_Report_Footer_Format: MsgBox Err.Number & vbCrLf & Err.Description Resume Exit_Report_Footer_Format End Sub 1626.BASE_P.accdb ماشاءالله عليك اخوي خليفة ، حبتين البهارات اللي اضفتها اعطت نتيجة احلى 🙂

تفضل استاذ @moho58 طلبك حسب مافهمت . ووافني بالرد . BASE_P-1.rar

لم افهم ما المقصود بالتنسيق وان كنت تقصد العمود الاخير M غير ظاهر في ملف PDF فاستبدل في الكود نطاق البيانات Range("A1:L" & lastRow).ExportAsFixedFormat _ بهذا المدى Range("A1:M" & lastRow).ExportAsFixedFormat _ يعتى بدل العمود L يصبح M عمالة نظام جديد2025_2026.xlsm

وعليكم السلام ورحمة الله وبركاته أخي @ابو نبأ الأمر بسيط جدا وسأشرح لك خطوة بخطوة كيف تضيف شرطا جديدا (مثل: موقع التحميل في العمود k) إلى الكود بحيث يمكنك لاحقا تعديل أو إضافة أي شرط بنفس الطريقة 1) التحقق من أن العمود الجديد (k) ليس فارغا If Trim(WS.Cells(i, "M").Text) <> "" And _ Trim(WS.Cells(i, "L").Text) <> "" And _ Trim(WS.Cells(i, "K").Text) <> "" And _ <===== (موقع التحميل) العمود الجديد 2) تعديل المفتاح M ليشمل القيمة الجديدة m = Trim(WS.Cells(i, "M").Text) & "|" & Trim(WS.Cells(i, "L").Text) & "|" & Trim(WS.Cells(i, "K").Text) 3) تعديل إخراج البيانات المفككة من المفتاح f = Split(k, "|") a = d(k) dest.Cells(r, 1).Resize(1, 7).Value = Array(f(0), f(1), f(2), a(0), a(1), a(2), a(3)) 4) لا تنسى تعديل رؤوس الأعمدة في الصف الأول لتتناسب مع التغيير dest.Range("A1").Resize(1, 7).Value _ = Array("الشهر", "اسم الشركة", "الموقع", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)") ليكون الكود النهائي بعد إظافة عمود موقع التحميل على الشكل التالي Option Explicit Sub TEST2() Dim dest As Worksheet, WS As Worksheet Dim m As String, a As Variant, k As Variant, f As Variant Dim d As Object: Set d = CreateObject("Scripting.Dictionary") Dim ShArr As Variant: ShArr = Array("aaa", "bbb") Dim i As Long, lr As Long, r As Long: r = 2 With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual On Error Resume Next Set dest = Sheets("تقرير مفصل") If dest Is Nothing Then Set dest = Sheets.Add dest.Name = "تقرير مفصل" Else With dest.Range("A:G") .ClearContents .Borders.LineStyle = xlNone End With End If On Error GoTo 0 dest.Range("A1").Resize(1, 7).Value _ = Array("الشهر", "اسم الشركة", "الموقع", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)") For Each WS In Sheets(ShArr) If WS.AutoFilterMode Then WS.AutoFilterMode = False lr = WS.Cells(WS.Rows.Count, "M").End(xlUp).Row For i = 2 To lr If Trim(WS.Cells(i, "M").Text) <> "" And Trim(WS.Cells(i, "L").Text) <> "" And Trim(WS.Cells(i, "K").Text) <> "" Then m = Trim(WS.Cells(i, "M").Text) & "|" & Trim(WS.Cells(i, "L").Text) & "|" & Trim(WS.Cells(i, "K").Text) If Not d.exists(m) Then d(m) = Array(0, 0, 0, 0) d(m) = Array(d(m)(0) + 1, d(m)(1) + tmp(WS.Cells(i, "S").Value), d(m)(2) + tmp(WS.Cells(i, "U").Value), d(m)(3) + tmp(WS.Cells(i, "F").Value)) End If Next i Next WS For Each k In d.Keys f = Split(k, "|") a = d(k) dest.Cells(r, 1).Resize(1, 7).Value = Array(f(0), f(1), f(2), a(0), a(1), a(2), a(3)) r = r + 1 Next k Call ShFormat(dest, "A:G") .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic End With MsgBox "تم إعداد التقرير المفصل بنجاح", vbInformation End Sub "======================================= Private Function tmp(x As Variant) As Double tmp = IIf(IsNumeric(x), x, 0) End Function '======================================= Private Sub ShFormat(ByRef WS As Worksheet, ByVal Col As String) With WS .Activate Dim lastRow As Long lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row With WS.Range("A1:G" & lastRow).Borders .LineStyle = xlDash: .Weight = xlThin: .ColorIndex = xlAutomatic End With .DisplayRightToLeft = True .Columns(Col).EntireColumn.AutoFit .Columns(Col).HorizontalAlignment = xlCenter .Columns(Col).VerticalAlignment = xlBottom .Range("E:G").NumberFormat = "0" End With End Sub ملاحظة : يمكنك تعطيل تنسيق الجدول النهائي بحذف أو تعليق هذا السطر أو تعديله ليشمل أعمدة أكثر إذا زادت الأعمدة لاحقا Call ShFormat(dest, "A:G") تقرير - حسب - الشهر - والشركة -الموقعV2 .xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Option Compare Text Sub FilterContractorData() Dim CrWS As Worksheet, dest As Worksheet, OnRng, ColArr, a(1 To 4) Const tmp1 = 3, tmp2 = 4, colDate = 1 Set CrWS = Sheets("يومية المقاولين") Set dest = Sheets("تقرير تفصيلى") With Application .ScreenUpdating = False: .Calculation = xlCalculationManual OnRng = CrWS.Range("B8:Y" & CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row).Value a(1) = dest.[D3].Value: a(2) = dest.[E3].Value a(3) = dest.[C6].Value: a(4) = dest.[D6].Value ColArr = FiltreTbl(OnRng, a, tmp1, tmp2, colDate, _ Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24)) If Not IsEmpty(ColArr) Then Dim Lr As Long: Lr = dest.Rows.Count dest.Range("A11:T" & Lr).ClearContents dest.Range("B11").Resize(UBound(ColArr), UBound(ColArr, 2)).Value = ColArr With dest.Range("A11:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-10") End With Else MsgBox "لا توجد بيانات تطابق الشروط المحددة", vbExclamation End If .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub Function FiltreTbl(OnRng, a, tmp1, tmp2, colDate, Optional f) Dim cnt(), temp(), b(), n&, j&, i&, k&, r&, vDate n = UBound(OnRng, 2) If IsMissing(f) Then ReDim cnt(0 To n - 1): For k = 0 To n - 1: cnt(k) = k + 1: Next k Else: cnt = f End If j = UBound(cnt): ReDim temp(1 To UBound(OnRng), 1 To j + 1) For i = LBound(OnRng) To UBound(OnRng) vDate = OnRng(i, colDate) If IsDate(vDate) And (a(1) = "" Or OnRng(i, tmp1) = a(1)) And (a(2) = "" Or OnRng(i, tmp2) = a(2)) _ And (vDate >= a(3) And vDate <= a(4)) Then r = r + 1: For k = 0 To j: temp(r, k + 1) = OnRng(i, cnt(k)): Next k End If Next i If r > 0 Then ReDim b(1 To r, 1 To j + 1) For i = 1 To r: For k = 1 To j + 1: b(i, k) = temp(i, k): Next k: Next i FiltreTbl = b Else: FiltreTbl = Empty End If End Function عمالة نظام جديد.xlsm

تفضل أخي Sub test() Dim dest As Worksheet, WS As Worksheet Dim m As String, a As Variant, k As Variant, f As Variant Dim d As Object: Set d = CreateObject("Scripting.Dictionary") Dim ShArr As Variant: ShArr = Array("aaa", "bbb") Dim i As Long, lr As Long, r As Long: r = 2 With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual On Error Resume Next Set dest = Sheets("التقرير") If dest Is Nothing Then Set dest = Sheets.Add: dest.Name = "التقرير" Else dest.Range("A:F").ClearContents On Error GoTo 0 dest.Range("A1").Resize(1, 6).Value _ = Array("الشهر", "اسم الشركة", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)") For Each WS In Sheets(ShArr) If WS.AutoFilterMode Then WS.AutoFilterMode = False lr = WS.Cells(WS.Rows.Count, "M").End(xlUp).Row For i = 2 To lr If Trim(WS.Cells(i, "M").Text) <> "" And Trim(WS.Cells(i, "L").Text) <> "" Then m = Trim(WS.Cells(i, "M").Text) & "|" & Trim(WS.Cells(i, "L").Text) If Not d.exists(m) Then d(m) = Array(0, 0, 0, 0) d(m) = Array(d(m)(0) + 1, d(m)(1) + tmp(WS.Cells(i, "S").Value), _ d(m)(2) + tmp(WS.Cells(i, "U").Value), d(m)(3) + tmp(WS.Cells(i, "F").Value)) End If Next i Next WS For Each k In d.Keys f = Split(k, "|") a = d(k) dest.Cells(r, 1).Resize(1, 6).Value = Array(f(0), f(1), a(0), a(1), a(2), a(3)) r = r + 1 Next k .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic End With MsgBox "تم إعداد التقرير بنجاح", vbInformation End Sub Private Function tmp(x As Variant) As Double tmp = IIf(IsNumeric(x), x, 0) End Function الشهر والشركة.xlsm

صوت الضمير 😊🖐️ أمال كل الدوشة اللي عملتها جوة دي تسميها أيه ؟؟ 🙃

الماكرو يجب وضعه في كود الصفحة التي تحتوي على cmdSearch وليس في Module مستقل