محمد هشام.

العفو أخي @mahmoud nasr alhasany يسعدني أنني إستطعت مساعدتك 😑

أحبك الذي أحببتني له

نعم أخي فقط قم بتعديل السطور التالية With tbl .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter .Rows.Alignment = wdAlignRowCenter .Borders.Enable = True Dim ColArr As Variant: ColArr = Array(80, 80, 200, 80, 80) For i = 0 To UBound(ColArr) .Columns(i + 1).PreferredWidth = ColArr(i) Next i End With تم تعديل الكود على الملف المرفق مع إظافة إمكانية حفظ الملف بصيغة PDF عند الحاجة ملف تصدير V4.xlsm

هل تقصد هدا التوكيلات.docx ملف تصدير V3.xlsm

وعليكم السلام ورحمة الله نعالى وبركاته يمكنك الإعتماد على ورقة مخفية ضمن المصنف لترحيل البيانات المطلوبة إليها وحفظها مباشرة بصيغة Word Option Explicit Private Const DocName As String = "التوكيلات" Private Const FolderName As String = "ملفات Word" Sub ExportToWord() Dim CrWS As Worksheet, dest As Worksheet, a As Variant, b As Variant Dim lastRow As Long, i As Long, savePath As String, xPath As String Dim wdApp As Object, wdDoc As Object, tbl As Object, d As Object, OnRng As Range Application.ScreenUpdating = False Set CrWS = Sheets("صلاحيات رواكد"): Set dest = Sheets("WordCopy"): Set d = CreateObject("Scripting.Dictionary") dest.Visible = xlSheetVisible a = CrWS.Range("A1:H" & CrWS.Cells(Rows.Count, 1).End(xlUp).Row).Value dest.Range("A1:E" & dest.Rows.Count).ClearContents For i = LBound(a) To UBound(a): d(i) = Array(a(i, 1), a(i, 3), a(i, 4), a(i, 6), a(i, 8)): Next i b = Application.Transpose(Application.Transpose(d.items)): dest.Range("A1").Resize(UBound(b), UBound(b, 2)) = b lastRow = dest.Cells(dest.Rows.Count, 1).End(xlUp).Row Set OnRng = dest.Range("A1:E" & lastRow) With OnRng .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Set wdApp = CreateObject("Word.Application"): wdApp.Visible = True: Set wdDoc = wdApp.Documents.Add wdDoc.PageSetup.Orientation = 1: OnRng.Copy: wdDoc.Content.Paste: Set tbl = wdDoc.Tables(1) With tbl: .Range.ParagraphFormat.Alignment = 1: .Borders.Enable = True Dim ColArr As Variant: ColArr = Array(110, 110, 250, 110, 110) For i = 0 To UBound(ColArr): .Columns(i + 1).PreferredWidth = ColArr(i): Next i End With With tbl.Rows.Add .Cells(4).Range.Text = ": المجموع": .Cells(5).Range.Text = Application.Sum(dest.Range("E2:E" & lastRow)) With .Cells(4).Range: .Font.Color = RGB(255, 0, 0): .ParagraphFormat.Alignment = 1: End With .Cells(5).Range.Font.Color = RGB(255, 0, 0): .Cells(5).Range.Font.Bold = True .Cells(1).Merge tbl.Rows(tbl.Rows.Count).Cells(4) End With xPath = ThisWorkbook.Path & "\" & FolderName If Dir(xPath, vbDirectory) = "" Then MkDir xPath savePath = xPath & "\" & DocName & ".docx" On Error Resume Next wdDoc.SaveAs savePath If Err.Number <> 0 Then MsgBox "الملف مفتوح بالفعل حاول إغلاقه والمحاولة مرة أخرى ", vbCritical wdDoc.Close False: wdApp.Quit: Set wdDoc = Nothing: Set wdApp = Nothing Exit Sub End If On Error GoTo 0 wdDoc.Close False: wdApp.Quit: Set wdDoc = Nothing: Set wdApp = Nothing dest.Visible = xlSheetVeryHidden: Set dest = Nothing Application.ScreenUpdating = True MsgBox "تم تصدير البيانات بنجاح" End Sub ملف تصدير V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته لست متأكدا من طلبك لاكن حاول تجربة هدا Option Explicit Private Const n As Long = 25 Private Const rHeight As Double = 20 Private Const tmps As Integer = 4 Private Const Col As String = "B" Sub PrintWS() Dim lr As Long, i As Long Dim lastCol As Long, OnRng As Range Dim CrWS As Worksheet Dim ColNum As Long Set CrWS = Sheets("Data") Application.ScreenUpdating = False CrWS.ResetAllPageBreaks Application.ActiveWindow.View = xlPageBreakPreview ColNum = CrWS.Range(Col & "1").Column lr = CrWS.Range(Col & CrWS.Rows.count).End(xlUp).Row CrWS.Rows("5:" & lr).RowHeight = rHeight If lr > tmps + n Then For i = tmps + n + 1 To lr Step n CrWS.HPageBreaks.Add Before:=CrWS.Rows(i) Next i End If lastCol = CrWS.Cells(tmps, CrWS.Columns.count).End(xlToLeft).Column Set OnRng = CrWS.Range(CrWS.Cells(tmps, ColNum), CrWS.Cells(lr, lastCol)) CrWS.PageSetup.PrintArea = OnRng.Address CrWS.VPageBreaks.Add Before:=CrWS.Columns(lastCol + 1) CrWS.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 With CrWS.PageSetup .Orientation = xlPortrait: .PaperSize = xlPaperA4 .FitToPagesWide = 1: .FitToPagesTall = False End With Application.ScreenUpdating = True End Sub Test V1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته إدا كنت قد فهمت طلبك بشكل صحيح فربما هدا سيوفي بالغرض Option Explicit Dim WS As Worksheet Dim OnRng As Variant Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set WS = Sheets("Sheet1") If Not Intersect([A2:A11], Target) Is Nothing And Target.Count = 1 Then OnRng = WS.Range("C2:C" & WS.Cells(WS.Rows.Count, "C").End(xlUp).Row).value Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.Height = Target.Height + 3 Me.ComboBox1.Width = Target.Width Me.ComboBox1.Top = Target.Top Me.ComboBox1.Left = Target.Left Me.ComboBox1.value = Target.value Me.ComboBox1.Visible = True Me.ComboBox1.Activate Else Me.ComboBox1.Visible = False End If End Sub Private Sub ComboBox1_Change() If Me.ComboBox1.value <> "" Then Dim d1 As Object Set d1 = CreateObject("Scripting.Dictionary") Dim tmp As String tmp = UCase(Me.ComboBox1.value) & "*" Dim i As Long For i = 1 To UBound(OnRng, 1) If UCase(OnRng(i, 1)) Like tmp Then d1(OnRng(i, 1)) = "" Next i Me.ComboBox1.List = d1.Keys Me.ComboBox1.DropDown End If ActiveCell.value = Me.ComboBox1.value End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then ActiveCell.Offset(1).Select End If End Sub قائمة منسدلة مع البحث والاكمال التلقائي.xlsb

تفضل جرب هدا التعديل Option Explicit Sub test() Dim wbDest As Workbook, wbData As Workbook Dim WS As Worksheet, CrWS As Worksheet Dim Irow&, nRow&, xPath$, xFile$, fname As Variant Dim i, j, k As Integer, ShArr As Variant, OnRng, tmps As Range Dim WSIndex As Integer SetApp False xPath = ThisWorkbook.Path fname = Array("رصيد التوكيلات1.xlsx", "رصيد التوكيلات_كفرالشيخ.xlsx", "رصيد التوكيلات_البحيرة.xlsx", _ "رصيد التوكيلات_طنطا.xlsx", "رصيد التوكيلات_المنصورة.xlsx", "رصيد التوكيلات_دكرنس.xlsx", _ "رصيد التوكيلات_دمياط.xlsx", "رصيد التوكيلات_المنوفية.xlsx", "رصيد التوكيلات_الشرقية.xlsx", _ "رصيد التوكيلات_الاسماعيلية.xlsx", "رصيد التوكيلات_بور سعيد.xlsx", "رصيد التوكيلات_السويس.xlsx", _ "رصيد التوكيلات_المقطم.xlsx", "رصيد التوكيلات_مؤسسة الزكاة.xlsx", "رصيد التوكيلات_الجيزة.xlsx", _ "رصيد التوكيلات_القليوبية.xlsx", "رصيد التوكيلات_الفيوم.xlsx", "رصيد التوكيلات_بنى سويف.xlsx", _ "رصيد التوكيلات_المنيا.xlsx", "رصيد التوكيلات_اسيوط.xlsx", "رصيد التوكيلات_سوهاج.xlsx", _ "رصيد التوكيلات_جرجا.xlsx", "رصيد التوكيلات_قنا.xlsx", "رصيد التوكيلات_نجع حمادى.xlsx", _ "رصيد التوكيلات_الغردقة.xlsx", "رصيد التوكيلات_الاقصر.xlsx", "رصيد التوكيلات_اسوان.xlsx", _ "رصيد التوكيلات_ادفو.xlsx") ShArr = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _ "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _ "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _ "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الاقصر", "اسوان", "ادفو") Set wbData = ThisWorkbook On Error Resume Next Set wbDest = Workbooks.Open(xPath & "\" & fname(0), ReadOnly:=True) If wbDest Is Nothing Then MsgBox "تعذر العثور على الملف " & fname(0), vbCritical SetApp True Exit Sub End If On Error GoTo 0 For WSIndex = LBound(fname) To UBound(fname) xFile = xPath & "\" & fname(WSIndex) On Error Resume Next Set wbDest = Workbooks.Open(xFile, ReadOnly:=True) If wbDest Is Nothing Then MsgBox "تعذر العثور على الملف " & fname(WSIndex), vbCritical SetApp True Exit Sub End If On Error GoTo 0 For i = LBound(ShArr) To UBound(ShArr) On Error Resume Next Set CrWS = wbData.Sheets(ShArr(i)) On Error GoTo 0 If Not CrWS Is Nothing Then Set WS = Nothing On Error Resume Next Set WS = wbDest.Sheets(ShArr(i)) On Error GoTo 0 If Not WS Is Nothing Then Irow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row If Irow < 4 Then GoTo SkipSheet End If For j = 6 To 19 Set tmps = CrWS.Cells(3, j) For k = 6 To 19 Set OnRng = WS.Cells(3, k) If OnRng.Value = tmps.Value And Not IsEmpty(OnRng.Value) Then For nRow = 4 To 71 If Not IsEmpty(WS.Cells(nRow, k).Value) Then CrWS.Cells(nRow, j).Value = WS.Cells(nRow, k).Value End If Next nRow Exit For End If Next k Next j For nRow = 4 To 71 If Not IsEmpty(WS.Cells(nRow, 2).Value) Then CrWS.Cells(nRow, 2).Value = WS.Cells(nRow, 2).Value End If Next nRow End If End If SkipSheet: Next i SkipFile: wbDest.Close False Next WSIndex MsgBox "تم نقل البيانات من جميع الملفات بنجاح", vbInformation SetApp True End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next Application.ScreenUpdating = enable Application.EnableEvents = enable Application.DisplayAlerts = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End Sub نقل البيانات من مصنفات متعددة.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub test() Dim wbDest As Workbook, wbData As Workbook Dim WS As Worksheet, CrWS As Worksheet Dim Irow&, lastCol&, nRow&, xPath$, xFile$, fname$ Dim i, j, k As Integer, ShArr As Variant, OnRng, tmps As Range SetApp False xPath = ThisWorkbook.Path fname = "رصيد التوكيلات1" xFile = xPath & "\" & fname & ".xlsx" If Dir(xFile) = "" Then MsgBox "تعذر العثور على الملف " & fname, vbCritical SetApp True Exit Sub End If Set wbData = ThisWorkbook ShArr = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _ "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _ "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _ "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الاقصر", "اسوان", "ادفو") On Error Resume Next Set wbDest = Workbooks.Open(xFile, ReadOnly:=True) If wbDest Is Nothing Then SetApp True Exit Sub End If On Error GoTo 0 For i = LBound(ShArr) To UBound(ShArr) On Error Resume Next Set WS = wbDest.Sheets(ShArr(i)) Set CrWS = wbData.Sheets(ShArr(i)) On Error GoTo 0 If Not WS Is Nothing And Not CrWS Is Nothing Then Irow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row If Irow >= 4 Then For j = 6 To 19 Set tmps = CrWS.Cells(3, j) For k = 6 To 19 Set OnRng = WS.Cells(3, k) If OnRng.Value = tmps.Value And Not IsEmpty(OnRng.Value) Then For nRow = 4 To 71 If Not IsEmpty(WS.Cells(nRow, k).Value) Then CrWS.Cells(nRow, j).Value = WS.Cells(nRow, k).Value End If Next nRow Exit For End If Next k Next j For nRow = 4 To 71 If Not IsEmpty(WS.Cells(nRow, 2).Value) Then CrWS.Cells(nRow, 2).Value = WS.Cells(nRow, 2).Value End If Next nRow End If End If Next i wbDest.Close False Cleanup: SetApp True MsgBox "تم نقل البيانات بنجاح", vbInformation End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next Application.ScreenUpdating = enable Application.EnableEvents = enable Application.DisplayAlerts = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End Sub نقل البيانات بين الملفات.rar

أعتقد أن الكود سهل في التعديل خاصة بعدما تم توضيح النقط المهمة لدالك صراحة لا أعلم ما تحاول فعله لاكن يمكنك جعل الكود مرن بدون تقييد للنطاقات إدا كنت بحاجة دائمة لإظافة أعمدة جديدة بحيث يمكنك تحديد أول عمود فقط داخل الكود وترك أخر عمود للبيانات تلقائي بحسب الأعمدة المتاحة لديك startRow = 7 ' أول صف للبيانات headerRow = 6 ' رقم صف عناوين رؤوس الأعمدة startCol = 5 ' أول عمود للبيانات المنسوخة ' العثور على اخر عمود endCol = WS.Cells.Find(what:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column With WS endRow = .Cells(.Rows.Count, startCol).End(xlUp).Row a = .Range(.Cells(startRow, startCol), .Cells(endRow, endCol)).Value End With Dim h As Variant ReDim headers(1 To UBound(a, 2)) h = WS.Range(WS.Cells(headerRow, startCol), WS.Cells(headerRow, endCol)).Value For i = 1 To UBound(a, 2) headers(i) = h(1, i) Next i colArr = Array(3, 4) ' المورد (G) والصنف (H) الزرع v5.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك إضافة قاعدة بيانات لأسماء الفرق والشعارات الخاصة بها في ورقة جديدة وتسميتها مثلا Logos واستخدام الكود التالي في حدث ورقة GroupA لتغيير الشعار تلقائيا بناء على التغيير في النتيجة عندما يتم نقل إسم الفريق في الورقة (أي تغيير موضع الخلية) سيتحرك الشعار إلى الموقع الجديد بشكل تلقائي كما في الصورة أدناه Option Explicit Private Sub Worksheet_Calculate() Dim tmp As Range, n As Shape, OnRng As Range Dim crWS As Worksheet: Set crWS = Me Dim dest As Worksheet: Set dest = Sheets("Logos") Application.ScreenUpdating = False For Each tmp In crWS.Range("J14:J" & crWS.Cells(crWS.Rows.Count, "J").End(xlUp).Row) If tmp.Value <> "" Then For Each n In crWS.Shapes If n.Type <> 8 And n.TopLeftCell.Address = tmp.Offset(0, -1).Address Then n.Delete Next n Set OnRng = dest.Range("A2:A" & dest.Cells(dest.Rows.Count, _ "A").End(xlUp).Row).Find(tmp.Value, LookAt:=xlWhole) If Not OnRng Is Nothing Then For Each n In dest.Shapes If n.TopLeftCell.Address = dest.Cells(OnRng.Row, _ dest.Range("A2:A" & dest.Cells(dest.Rows.Count, "A").End(xlUp).Row).Column + 1).Address Then n.Copy tmp.Offset(0, -1).Select ActiveSheet.Paste With Selection.ShapeRange .LockAspectRatio = msoFalse .Left = tmp.Offset(0, -1).Left + 4: .Top = tmp.Offset(0, -1).Top + 5 .Width = tmp.Offset(0, -1).Width - 8: .Height = tmp.Offset(0, -1).Height - 6 End With Selection.ShapeRange(1).Select Selection.ShapeRange(1).TopLeftCell.Select End If Next n Else For Each n In crWS.Shapes If n.Type <> 8 And n.TopLeftCell.Address = tmp.Offset(0, -1).Address Then n.Delete Next n End If End If Next tmp Application.CutCopyMode = False Application.ScreenUpdating = True End Sub تجريبة v2.xlsb

يجب أخي تعديل النطاق المرغوب داخل الكود مثلا With WS ' نطاق البيانات a = .Range("E7:O" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value ' عناوين رؤوس الأعمدة headers = Array("م", "التاريخ", "العدد", "المورد", "الصنف", "القائم", "الفارغ", _ "الصافي", "السعر", "القيمة", "متوسط سعر البرنيكة", "متوسط وزن البرنيكة") End With النطاق الهدف On Error Resume Next lastRow = dest.Columns("A:L").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 If lastRow = 0 Then lastRow = 9 Set rng = dest.Range("A9:L" & lastRow) الزرع v4.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة أخرى Option Explicit Sub test() Dim WS As Worksheet, tbl As Long, tmp As Long, i As Long Dim n As String, Max As Long, ky As Boolean Max = 34 Set WS = Sheets("ورقة1") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual On Error Resume Next tbl = WS.Columns("B:M").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 tbl = IIf(tbl = 0, 6, tbl) tbl = IIf(tbl > Max, Max, tbl) WS.Range("N6:N" & tbl).ClearContents For tmp = 6 To tbl n = "" ky = False For i = 2 To 13 If WS.Cells(tmp, i).Value <> "" Then n = IIf(n = "", WS.Cells(5, i).Text, n & " - " & WS.Cells(5, i).Text) If Not ky Then WS.Cells(tmp, 14).NumberFormat = WS.Cells(tmp, i).NumberFormat ky = True End If End If Next i WS.Cells(tmp, 14).Value = n Next tmp Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub DATA V1.xlsb

تفضل أخي Option Explicit Sub test() Dim i, j, tbl, k, lastRow As Long, rng As Range, c As Range, s As String Dim dic As Object, WS As Worksheet, dest As Worksheet Dim a, headers, result, colArr, tmp As Variant Set WS = Sheets("يومية المقاولين") With Application .ScreenUpdating = False .Calculation = xlCalculationManual Set dic = CreateObject("Scripting.Dictionary") With WS a = .Range("E7:M" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value headers = Array("م", "التاريخ", "العدد", "المورد", "الصنف", "القائم", _ "الفارغ", "الصافي", "السعر", "القيمة") End With colArr = Array(3, 4) ' المورد (G) و الصنف (H) For Each tmp In colArr dic.RemoveAll For i = 1 To UBound(a, 1) s = Trim(CStr(a(i, tmp))) If Len(s) > 0 And Not dic.exists(s) Then dic(s) = Empty s = Replace(s, "/", "_"): s = Replace(s, "\", "_") On Error Resume Next Set dest = Sheets(s) On Error GoTo 0 If dest Is Nothing Then Set dest = Sheets.Add(, Sheets(Sheets.Count)) dest.Name = s dest.DisplayRightToLeft = True dest.Rows("9").RowHeight = 20 Else dest.Range("A9:J" & dest.Rows.Count).Clear End If With dest.Range("A9:J9") .Value = headers: .Font.Bold = True: .Interior.Color = RGB(204, 255, 255) End With tbl = 0 For j = 1 To UBound(a, 1) If Trim(CStr(a(j, tmp))) = s Then tbl = tbl + 1 Next j ReDim result(1 To tbl, 1 To UBound(a, 2)) tbl = 1 For j = 1 To UBound(a, 1) If Trim(CStr(a(j, tmp))) = s Then For k = 1 To UBound(a, 2) result(tbl, k) = a(j, k) Next k tbl = tbl + 1 End If Next j dest.Range("B10").Resize(UBound(result, 1), UBound(result, 2)).Value = result dest.Range("A10:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row).Value = _ Evaluate("ROW(" & dest.Range("A10:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row).Address & ")-9") On Error Resume Next lastRow = dest.Columns("A:J").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 If lastRow = 0 Then lastRow = 9 Set rng = dest.Range("A9:J" & lastRow) With rng .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter .Borders.LineStyle = xlNone: .ColumnWidth = 10 End With For Each c In rng.Rows If Application.WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next c End If Set dest = Nothing Next i Next tmp WS.Activate .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الزرع v3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub test() Dim a As Variant, headers As Variant, result As Variant, dic As Object, WS As Worksheet, dest As Worksheet Dim i As Long, j As Long, s As String, rowCount As Long, k As Long, lastRow As Long, rng As Range, c As Range Set WS = Sheets("يومية المقاولين") With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Set dic = CreateObject("Scripting.Dictionary") With WS a = .Range("E7:M" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value headers = Array("م", "التاريخ", "العدد", "المورد", "الصنف", "القائم", "الفارغ", "الصافي", "السعر", "القيمة") End With For i = 1 To UBound(a, 1) s = Trim(CStr(a(i, 3))) If Len(s) > 0 And Not dic.exists(s) Then dic(s) = Empty s = Replace(s, "/", "_"): s = Replace(s, "\", "_") On Error Resume Next Set dest = Sheets(s) On Error GoTo 0 If dest Is Nothing Then Set dest = Sheets.Add(, Sheets(Sheets.Count)) dest.Name = s dest.DisplayRightToLeft = True Else dest.Range("A9:J" & dest.Rows.Count).Clear End If With dest.Range("A9:J9") .Value = headers .Font.Bold = True .Interior.Color = RGB(204, 255, 255) End With rowCount = 0 For j = 1 To UBound(a, 1) If Trim(CStr(a(j, 3))) = s Then rowCount = rowCount + 1 Next j ReDim result(1 To rowCount, 1 To UBound(a, 2)) rowCount = 1 For j = 1 To UBound(a, 1) If Trim(CStr(a(j, 3))) = s Then For k = 1 To UBound(a, 2) result(rowCount, k) = a(j, k) Next k rowCount = rowCount + 1 End If Next j dest.Range("B10").Resize(UBound(result, 1), UBound(result, 2)).Value = result With dest.Range("A10:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-9") End With On Error Resume Next lastRow = dest.Columns("A:J").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 If lastRow = 0 Then lastRow = 9 Set rng = dest.Range("A9:J" & lastRow) With rng .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Borders.LineStyle = xlNone .ColumnWidth = 10 End With For Each c In rng.Rows If Application.WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next c End If Set dest = Nothing Next i WS.Activate With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الزرع v2.xlsm