محمد هشام.

1) أولا يسعدنا أخي @saad abed أننا إستطعنا مساعدتك 2) نعم إلغاء الرسائل وتحديث الشاشة يسرع الكود بشكل كبير Sub SupApp(ByVal disable As Boolean) With Application If disable Then .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False .Calculation = xlCalculationManual Else .ScreenUpdating = True .EnableEvents = True .DisplayAlerts = True .Calculation = xlCalculationAutomatic End If End With End Sub وقد تم تطبيق ذلك في الكود باستخدام SupApp(True) لأنها توقف التحديث البصري للشاشة وتمنع ظهور رسائل التنبيه مثل هل تريد حفظ التغييرات؟ وتوقف الأحداث البرمجية مثل الأكواد المرتبطة بفتح الملفات وكدالك تعطل إعادة الحساب التلقائي للصيغ هذا ما يحسن من سرعة الكود ويقلل من وقت تنفيذ العمليات بشكل ملحوظ خاصة عند معالجة عدد كبير من الملفات

وعليكم السلام ورحمة الله تعالى وبركاته 1) الصور التي أرفقتها توضح أن ملفك يحتوي على روابط خارجية وهي تشير إلى بيانات في ملفات أخرى عند فتح الملف يحاول تحديث هذه الروابط تلقائيا وإذا لم يجد الملفات المرتبطة أو كانت غير متاحة تظهر هذه الرسائل التحذيرية يمكنك استخدام Break Link لكسر الرابط نهائيا لتفادي ظهورها مجددا 2) مجرد اقتراح الأكواد مكررة بشكل كبير يمكن استبدالها بوظيفة واحدة تقبل اسم المنطقة كمتغير بدلا من 36 ماكرو منفصل Sub filtrage(arrName As String, names As String) On Error GoTo ClearApp If ActiveSheet.AutoFilterMode = False Then Range("A1").AutoFilter ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:="=" & arrName, Operator:=xlOr, Criteria2:="=الاجمالى" Range("B5").Value = names Range("A3").Select Exit Sub ClearApp: End Sub ثم تستدعيها مثلا بهذا الشكل Sub صندوق_التمويل() Call filtrage("صندوق التمويل", "صندوق التمويل") End Sub جرب هدا بعد كسر الإرتباطات وتنظيم الأكواد مرتبات لسنة 2025.xls

تفضل أخي بناء على نفس الفكرة السابقة أرفق لك ملف يحتوي على كودين: الكود الأول: إنشاء مجلدات وملفات بصيغة xlsb للتجربة تم تعديل الكود بحيث يمكنك: 1) اختيار البارتيشن الذي تريد إنشاء الملفات فيه 2) تحديد عدد المجلدات التي سيتم إنشاؤها 3) تحديد عدد الملفات داخل كل مجلد حسب حاجتك الكود الثاني: تحويل جميع ملفات xlsb في البارتيشن المحدد الكود يقوم بـالبحث داخل البارتيشن الذي تحدده وتحويل جميع الملفات ذات الامتداد xlsb إلى صيغة أخرى xlsx داخل البارتشن المحدد حتى وإن كانت مخزنة داخل مجلدات فرعية متداخلة Option Explicit Sub Convertfiles() Dim dl As Object, n As String, ky As String Dim files() As String, i As Long, a As Long Dim startTime As Double, confirm As VbMsgBoxResult n = "F:\" ' لا تنسى تعديل إسم البارتيشن بما يناسبك confirm = MsgBox("سيتم تحويل جميع الملفات بصيغة xlsb إلى xlsx" & vbCrLf & _ "هل تريد المتابعة؟", vbYesNo + vbQuestion, n & " " & "محرك الأقراص") If confirm <> vbYes Then Exit Sub Set dl = CreateObject("Scripting.FileSystemObject") startTime = Timer SupApp True ky = tMps(dl, n) If Trim(ky) = "" Then MsgBox "xlsb" & " " & "لم يتم العثور على أي ملفات بصيغة ", vbInformation GoTo Cleanup End If files = Split(ky, vbCrLf) a = 0 For i = LBound(files) To UBound(files) If Trim(files(i)) <> "" Then If CntFiles(Trim(files(i)), dl) Then a = a + 1 End If End If Next i MsgBox "تم تحويل" & a & " ملف بنجاح" & vbCrLf & _ "استغرق التنفيذ " & Format(Timer - startTime, "0.00") & " ثانية", vbInformation Cleanup: SupApp False End Sub Function CntFiles(filePath As String, dl As Object) As Boolean Dim wb As Workbook Dim newPath As String On Error GoTo ClearApp Set wb = Workbooks.Open(filePath, ReadOnly:=False) newPath = Replace(filePath, ".xlsb", ".xlsx") wb.SaveAs fileName:=newPath, FileFormat:=xlOpenXMLWorkbook wb.Close SaveChanges:=False If dl.FileExists(newPath) Then dl.DeleteFile filePath, True CntFiles = True End If Exit Function ClearApp: CntFiles = False If Not wb Is Nothing Then wb.Close SaveChanges:=False End Function Function tMps(dl As Object, n As String) As String Dim root As Object, list As Collection, item As Variant, result As String On Error Resume Next Set root = dl.GetFolder(n) If root Is Nothing Then Exit Function On Error GoTo 0 Set list = New Collection Call ScanFiles(dl, root, list) For Each item In list result = result & item & vbCrLf Next item tMps = result End Function Sub ScanFiles(dl As Object, folder As Object, ByRef list As Collection) Dim file As Object, subFolder As Object, fName As String fName = LCase(folder.Path) If InStr(fName, "$recycle.bin") > 0 Then Exit Sub If InStr(fName, "system volume information") > 0 Then Exit Sub For Each file In folder.files If LCase(dl.GetExtensionName(file.Name)) = "xlsb" Then list.Add file.Path End If Next For Each subFolder In folder.SubFolders ScanFiles dl, subFolder, list Next End Sub TEST4.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا هل يناسبك Option Explicit Sub FilterByNames() Dim WS As Worksheet, arr(), i&, n&, filterRange As Range Set WS = Sheets("Sheet1") If WS.AutoFilterMode Then WS.AutoFilterMode = False n = WS.Cells(WS.Rows.Count, "I").End(xlUp).Row If n < 2 Then Exit Sub ReDim arr(1 To n - 1) For i = 2 To n arr(i - 1) = WS.Cells(i, "I").Value Next i Set filterRange = WS.Range("B6").CurrentRegion With filterRange .AutoFilter Field:=2, Criteria1:=arr, Operator:=xlFilterValues End With End Sub

أظن أن الأمر ليس بالصعب يمكننا تعديل الكود ليتناسب مع طلبك بحيث يقوم بحدف الملفات سواءا بداخل البارتيشن المحدد مباشرة أو بداخل الملفات الفرعية بما أنه من الصعب تجربة الكود على الملفات الخاصة بي قمت بإنشاء بارتيشن إظافي بإسم F فقط للتجربة يمكنك تغييره بداخل الكود على حسب احتياجاتك مع إظافة كود لإنشاء ملفات بصيغة XLSB للتجربة عليها كما في المثال التالي TEST3.xlsm

جزاكم الله خير الجزاء على دعواتكم الصادقة لابني بالشفاء وأشكر كل من سأل ودعا من القلب فدعاؤكم كان له أثر كبير في رفع معنوياتنا وتخفيف ألمنا أسأل الله أن يكتب لكم الأجر ويجزيكم خيرا اللهم لك الحمد على نعمة الأحبة والأصدقاء الصادقين الذين لم ينسونني من دعواتهم شكرا لكم جميعا وأسأل الله لكم دوام الصحة والعافية وأن لا يريكم مكروها فيمن تحبون

ادن لنجرب طريقة أخرى 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

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

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

dest.Range("A11:T" & Lr).ClearContents =========> dest.Range("A11:Y" & Lr).ClearContents Private Sub ShFormat(ByRef dest As Worksheet, ByVal Col As String) Dim lastRow As Long lastRow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row With dest.Range("A11:Y" & lastRow).Borders .LineStyle = xlDash: .Weight = xlThin: .ColorIndex = xlAutomatic End With End Sub Dim Lr As Long: Lr = dest.Rows.Count With dest.Range("A11:Y" & Lr) .ClearContents: .Borders.LineStyle = xlNone End With عمالة نظام 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

الأعمدة عندك ثابثة لغاية عمود Y ممكن تخفيها يدويا عادي أما الصفوف مادا تقصد هل الغاء تنسيق الأعمدة الغير مستخدمة كحدف التسطير او اخفائها نهائيا

وعليكم السلام ورحمة الله تعالى وبركاته 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