محمد هشام.

نعم أخي يمكنك تعديل السطور الأخيرة من الكود Dim fichier As String ' قم بتحديد خلية الإسم بما يناسبك fichier = WS.Range("E30").Value filePath = pdfFolder & "\" & fichier & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Cnt: Next r MsgBox "تم تصدير الملفات إلى مجلد: " & FolderName, vbInformation Unload Me وبما أن ورقة Round 5 تتضمن إسم المستفيد على عمود c يمكنك استخدام هدا ليتم تسمية الملف ديناميكيا عند التنفيد مع مزيدا من التحقق Private Sub CommandButton2_Click() Dim r As Long, s As Long, t As Long, FolderName As String, pdfFolder As String, i As Integer Dim filePath As String, ID As String, Item As String, tmp As String, Chars As String If Trim(TextBox1.Value) = "" Or Trim(TextBox2.Value) = "" Or _ Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then MsgBox "الرجاء التحقق من أرقام الإيصالات", vbCritical Exit Sub End If s = CLng(TextBox1.Value): t = CLng(TextBox2.Value) For r = s To t If Trim(dest.Range("B" & r + 2).Value) <> "" Then Exit For Next r If r > t Then: MsgBox "لا يوجد أي إيصالات للحفظ على قاعدة البيانات", vbExclamation: Exit Sub pdfFolder = ThisWorkbook.Path & "\الإيصالات" If Dir(pdfFolder, vbDirectory) = "" Then MkDir pdfFolder Chars = "\ / : * ? "" < > |" For r = s To t ID = Trim(dest.Range("B" & r + 2).Value) '(C)'جلب إسم المستفيد من عمود Item = Trim(dest.Range("C" & r + 2).Value) '(ID)' تجاهل حفظ الملف عند التحقق من عدم وجود إسم المستفيد أو رقم If ID = "" Or Item = "" Then GoTo Cnt tmp = Item For i = 1 To Len(Chars) tmp = Replace(tmp, Mid(Chars, i, 1), "") Next i filePath = pdfFolder & "\" & tmp & ".pdf" WS.[d4] = ID: WS.[U2] = ID On Error Resume Next WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Cnt: Next r MsgBox ": تم تصدير الملفات إلى مجلد" & pdfFolder, vbInformation Unload Me End Sub PTT 2024 v3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ادا كنت قد إستوعبت طلبك بشكل صحيح فربما هدا سيوفي بالغرض ملاحظة : الملف يتضمن عدة أكواد يجب وضع كل كود في مكانه المناسب في Module1 ضع الأكواد التالية Const a As String = "الرئيسية" Const b As String = "تقرير بالموقع" Const c As String = "تقرير بالمنتج" Public Property Get WS() As Worksheet Set WS = Sheets(a) End Property Public Property Get dest() As Worksheet Set dest = Sheets(b) End Property Public Property Get dest2() As Worksheet Set dest2 = Sheets(c) End Property Sub Run_MainFilter() Call FilterData("J", dest, dest.Range("B2")) Call ApplyBorders(ActiveSheet) End Sub Sub Run_SecondaryFilter() Call FilterData("D", dest2, dest2.Range("B2")) Call ApplyBorders(ActiveSheet) End Sub ' دالة لفلترة البيانات Private Sub FilterData(srcColumn As String, srsWS As Worksheet, Clé As Range) Dim arr() As Variant, dataRange As Range, lastRow As Long Dim Crite As String, ColArr As Long, N As Long, lastCol As Long Crite = Clé.Value lastRow = WS.Cells(WS.Rows.Count, srcColumn).End(xlUp).Row If WS.Range(srcColumn & "3:" & srcColumn & lastRow).Find(Crite, _ LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then MsgBox Crite & " غير موجود", vbExclamation Exit Sub End If Application.ScreenUpdating = False srsWS.Range("A5:J" & srsWS.Rows.Count).ClearContents arr = WS.Range("A3:K" & WS.Cells(WS.Rows.Count, "I").End(xlUp).Row).Value N = 5 For ColArr = 1 To UBound(arr, 1) If arr(ColArr, WS.Range(srcColumn & "1").Column) = Crite Then srsWS.Cells(N, 1).Resize(1, 10).Value _ = Application.Index(arr, ColArr, Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11)) N = N + 1 End If Next ColArr lastCol = srsWS.Cells(5, srsWS.Columns.Count).End(xlToLeft).Column lastRow = srsWS.Cells(srsWS.Rows.Count, "A").End(xlUp).Row srsWS.PageSetup.PrintArea = srsWS.Range("A1", srsWS.Cells(lastRow, lastCol)).Address Application.ScreenUpdating = True End Sub ' تعبئة القائمة المنسدلة تقرير المنتج Sub AddDropdown_Main() Dim Data As Range, destCell As Range Dim lastRow As Long, OnRng As String OnRng = "Dropdown_Main" Set destCell = dest.Range("B2") lastRow = WS.Cells(WS.Rows.Count, "P").End(xlUp).Row Set Data = WS.Range("P2:P" & lastRow) On Error Resume Next ThisWorkbook.Names(OnRng).Delete On Error GoTo 0 ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data With destCell.Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & OnRng .IgnoreBlank = True .InCellDropdown = True End With End Sub ' تعبئة القائمة المنسدلة تفرير بالموقع Sub AddDropdown_Secondary() Dim Data As Range, destCell As Range Dim lastRow As Long, OnRng As String OnRng = "Dropdown_Secondary" Set destCell = dest2.Range("B2") lastRow = WS.Cells(WS.Rows.Count, "O").End(xlUp).Row Set Data = WS.Range("O2:O" & lastRow) On Error Resume Next ThisWorkbook.Names(OnRng).Delete On Error GoTo 0 ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data With destCell.Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & OnRng .IgnoreBlank = True .InCellDropdown = True End With End Sub ' تسطير البيانات Sub ApplyBorders(wsTarget As Worksheet) Dim lastRow As Long, rng As Range lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then Exit Sub Application.ScreenUpdating = False wsTarget.Range("A5:J100").Borders.LineStyle = xlNone Set rng = wsTarget.Range("A5:J" & lastRow) With rng.Borders .LineStyle = xlContinuous .Color = RGB(0, 0, 0) .Weight = xlThin End With Application.ScreenUpdating = True End Sub وفي حدث ورقة الرئيسية Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim tmp As Object, item As Range, OnRng As Range, ColArr As Range Dim LastRow As Long Application.ScreenUpdating = False If Not Intersect(Target, Me.Columns("D")) Is Nothing Or _ Not Intersect(Target, Me.Columns("J")) Is Nothing Then If Not Intersect(Target, Me.Columns("D")) Is Nothing Then Set ColArr = Me.Range("D3", Me.Cells(Me.Rows.Count, "D").End(xlUp)) Set OnRng = Me.Range("O2:O65000") Else Set ColArr = Me.Range("J3", Me.Cells(Me.Rows.Count, "J").End(xlUp)) Set OnRng = Me.Range("P2:P65000") End If Set tmp = CreateObject("Scripting.Dictionary") For Each item In ColArr If item.Value <> "" Then tmp(item.Value) = "" Next item OnRng.ClearContents If tmp.Count > 0 Then OnRng.Resize(tmp.Count, 1).Value = Application.Transpose(tmp.Keys) End If End If Application.ScreenUpdating = True End Sub في حدث ورقة تقرير بالموقع Private Sub CommandButton1_Click() Call SaveRangeAsPDF End Sub Private Sub Worksheet_Activate() Call AddDropdown_Secondary End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B2")) Is Nothing Then If Me.Range("B2").Value = "" Then _ MsgBox "برجاء إدخال إسم الموقع ", vbCritical: Exit Sub Call Run_SecondaryFilter End If End Sub وفي حدث ورقة تقرير بالمنتج Private Sub CommandButton1_Click() Call SaveRangeAsPDF End Sub Private Sub Worksheet_Activate() Call AddDropdown_Main End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B2")) Is Nothing Then If Me.Range("B2").Value = "" Then _ MsgBox "برجاء إدخال إسم المنتج ", vbCritical: Exit Sub Call Run_MainFilter End If End Sub وأخيرا في موديول جديد الكود الخاص بحفظ الملفات بصيغة PDF Option Explicit Sub SaveRangeAsPDF() Dim WSdest As Worksheet, sFile As String, folderName As String, sPath As String Dim lastRow As Long, lastCol As Long, pdfPath As String Set WSdest = ActiveSheet sFile = WSdest.Name folderName = "ملفات PDF" sPath = ThisWorkbook.Path & Application.PathSeparator & folderName & Application.PathSeparator On Error Resume Next If Len(Dir(sPath, vbDirectory)) = 0 Then MkDir sPath On Error GoTo 0 lastRow = WSdest.Cells(WSdest.Rows.Count, "A").End(xlUp).Row lastCol = WSdest.Cells(5, WSdest.Columns.Count).End(xlToLeft).Column WSdest.PageSetup.PrintArea = WSdest.Range("A1", WSdest.Cells(lastRow, lastCol)).Address With WSdest.PageSetup .Orientation = xlLandscape .PaperSize = xlPaperA4 .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With pdfPath = sPath & sFile & ".pdf" WSdest.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfPath, Quality:=xlQualityStandard MsgBox "تم حفظ الملف بنجاح", vbInformation End Sub بالتوفيق ............ جرد المنتج_V2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته دالة IF تحتاج إلى شروط واضحة وتنتظر تحديد ما يجب أن يتم في حال كان الشرط صحيحا أو خطأفي حالتك IF "" غير مكتمل لأنك لم تحدد ما يجب تنفيذه في حال كانت الشروط فارغة أو صحيحة إذا كنت تحاول استخدام دالة IF مع FILTER لتحديد قيمة فارغة مثلا عند عدم وجود نتائج في FILTER فيمكنك استخدام دالة IFERROR =IFERROR(FILTER(AP4:AT353, ISNUMBER(SEARCH(AF6, AQ4:AQ353))), "") مع التأكد من أن الفواصل في الصيغة تتناسب مع الاصدار الموجود لديك ; او ,

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Public Property Get WS() As Worksheet Set WS = Sheets("PTT") End Property Public Property Get dest() As Worksheet Set dest = Sheets("Round 5") End Property Private Sub CommandButton1_Click() Dim r As Long, s As Long, t As Long, tmp As Long, ID As String, n As Boolean If Trim(TextBox1.Value) = "" Or Trim(TextBox2.Value) = "" Or _ Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then MsgBox "الرجاء التحقق من أرقام الإيصالات ", vbCritical Exit Sub End If s = CLng(TextBox1.Value): t = CLng(TextBox2.Value) n = True For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) <> "" Then n = False Exit For End If Next r If n Then MsgBox "لا يوجد أي إيصالات للطباعة على قاعدة البيانات ", vbExclamation Exit Sub End If On Error Resume Next For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) = "" Then GoTo Cnt WS.[d4] = ID WS.[U2] = ID Err.Clear WS.PrintOut If Err.Number <> 0 Then MsgBox "تم إلغاء طباعة الإيصالات", vbExclamation Exit Sub End If Cnt: Next r WS.[aa1] = s WS.[aa2] = t Unload Me End Sub '===================================== Private Sub CommandButton2_Click() Dim r As Long, tmp As Long, s As Long, t As Long, FolderName As String Dim filePath As String, ID As String, n As Boolean, pdfFolder As String If Trim(TextBox1.Value) = "" Or Trim(TextBox2.Value) = "" Or _ Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then MsgBox "الرجاء التحقق من أرقام الإيصالات ", vbCritical Exit Sub End If s = CLng(TextBox1.Value): t = CLng(TextBox2.Value) n = True For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) <> "" Then n = False Exit For End If Next r If n Then: MsgBox "لا يوجد أي إيصالات للحفظ على قاعدة البيانات ", vbExclamation: Exit Sub FolderName = "الإيصالات" pdfFolder = ThisWorkbook.Path & "\" & FolderName If Dir(pdfFolder, vbDirectory) = "" Then On Error Resume Next MkDir pdfFolder If Err.Number <> 0 Then: Exit Sub On Error GoTo 0 End If For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) = "" Then GoTo Cnt End If WS.[d4] = ID: WS.[U2] = ID filePath = pdfFolder & "\invoice_" & ID & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Cnt: Next r MsgBox "تم تصدير الملفات إلى مجلد: " & FolderName, vbInformation Unload Me End Sub PTT 2024 v2.xlsm

ولا يهمك أخي @محمد العراقى سنكون سعداء دائما بحصولك على النتائج المطلوبة يكفي تعديل هدا الجزء من الكود For j = LBound(DaysArr) To UBound(DaysArr) For i = 0 To 7 ' الحصص dest.Cells(Irow, i + 2).Value = WS.Cells(OnRng.Row, cnt + i).Value ' المواد If WS.Cells(OnRng.Row + 1, cnt + i).Value <> "" Then dest.Cells(Irow + 1, i + 2).Value = WS.Cells(OnRng.Row + 1, cnt + i).Value End If Next i cnt = cnt + 8 Irow = Irow + 2 Next j اجر-V2.xls

وعليكم السلام ورحمة الله تعالى وبركاته ربما هدا ماتقصده بما أنك فاهم الكود سأوضح فقط ما تم تعديله If Not OnRng Is Nothing Then arr = Array("السبت", "الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس") Irow = 10 cnt = 7 Application.ScreenUpdating = False 'افراغ البيانات السابقة dest.Range("b10:Q21").ClearContents ReDim dataArr(0 To UBound(arr), 0 To 7) For j = 0 To UBound(arr) For i = 0 To 7 dataArr(j, i) = WS.Cells(OnRng.Row, cnt + i).Value Next i cnt = cnt + 8 Next j For j = 0 To UBound(arr) For i = 0 To 7 ' نسخ بيانات اليوم dest.Cells(Irow, i + 2).Value = dataArr(j, i) If IsDate(dest.Cells(Irow, i + 2).Value) Then dest.Cells(Irow, i + 2).NumberFormat = "@" End If ' اظافة اسم المادة في الصف الموالي If dataArr(j, i) <> "" Then dest.Cells(Irow + 1, i + 2).Value = WS.Cells(OnRng.Row, 3).Value End If Next i Irow = Irow + 2 Next j '========== جلب المعلومات الإضافية ============ ' الاسم الرباعي للمعلم' الرقـم القومي ' الفـصــول ' المـــادة' عـدد الحصص المنفذة Dim CellArr As Variant, ColArr As Variant CellArr = Array("E5", "O5", "C6", "H6", "Q6") ColArr = Array(2, 4, 5, 3, 6) For i = LBound(CellArr) To UBound(CellArr) dest.Range(CellArr(i)).Value = WS.Cells(OnRng.Row, ColArr(i)).Value Next i Else MsgBox "لم يتم العثور على تسلسل المعلم " & linge, vbExclamation End If بالتوفيق...... اجر.xls

يمكنك دمج الطريقتين مع بعض كما في الصورة ListBox1.ColumnCount = 12-V3.xlsm

جرب هدا بعد تنفيد ما سبق دكره سابقا Sub CopyDataOnGroups() Dim lastrow&, r&, Irow& Dim ShtOne As Worksheet, WS As Worksheet Dim rng As Boolean, arr As Variant, tmp As Range Dim lingHeader As Range, cell As Range, data As Variant Dim ColHeader As Range, a As Range, OnRng As Range Dim Group As Boolean, n As Boolean Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set ShtOne = Sheets("التجميع") ShtOne.Range("B3:BD" & ShtOne.Rows.Count).Clear arr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5") For Each sheetName In arr Set WS = Sheets(sheetName) lastrow = WS.Columns("B:BD").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastrow < 1 Then GoTo NextSheet For Each lingHeader In WS.Range("B19", WS.Cells(19, WS.Cells(19, Columns.Count).End(xlToLeft).Column)).Cells If lingHeader.MergeCells Then Set lingHeader = lingHeader.MergeArea.Cells(1, 1) For Each tmp In WS.Range(lingHeader.Offset(1, 0), WS.Cells(20, lingHeader.MergeArea.Columns.Count + lingHeader.Column - 1)) Group = False n = False rng = False For Each ColHeader In ShtOne.Range("B1", ShtOne.Cells(1, ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column)).Cells If ColHeader.MergeCells Then Set ColHeader = ColHeader.MergeArea.Cells(1, 1) If Trim(lingHeader.Value) = Trim(ColHeader.Value) Then Group = True For Each a In ShtOne.Range(ColHeader.Offset(1, 0), _ ShtOne.Cells(2, ColHeader.MergeArea.Columns.Count + ColHeader.Column - 1)) If Trim(tmp.Value) = Trim(a.Value) Then n = True Set OnRng = WS.Range(tmp.Offset(1, 0), WS.Cells(lastrow, tmp.Column)) r = ShtOne.Cells(ShtOne.Rows.Count, a.Column).End(xlUp).Row Irow = r + 1 For Each cell In OnRng data = cell.Value If Application.CountIf(ShtOne.Range(ShtOne.Cells(3, a.Column), ShtOne.Cells(r, a.Column)), data) > 0 Then rng = True Exit For End If Next cell If Not rng Then OnRng.Copy ShtOne.Cells(Irow, a.Column).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Application.CutCopyMode = False End If Exit For End If Next a End If If Group And n Then Exit For Next ColHeader Next tmp Next lingHeader NextSheet: Next sheetName Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub المصنف 4.xlsb

آسف أخي @saad1391 فعلا لم انتبه لردك إلا بالصدفة كان الفكرة الموضحة في الصور قد تم تنفيذها يدويا لاكن بعد محاولة تنفيذها بواسطة الأكواد إكتشفت ان طريقة تصميمك للملف وكثرة الخلايا المدمجة يصعب التعامل معها حاول إلغاء دمجها قدر الإمكان للتخلص من الأعمدة الفارغة التي تعيق استخراج النتائج بشكل صحيح

جرب هدا Dim OnRng(), tbl, Irow, ColVisu(), Dates(), Choix() Private Sub UserForm_Initialize() tbl = "Table2" OnRng = Range(tbl).value For i = 1 To UBound(OnRng): OnRng(i, 2) = CDate(OnRng(i, 2)): Next i Irow = Range(tbl).Columns.Count ColVisu = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12) ListBox1.ColumnCount = 12 Set d = CreateObject("scripting.dictionary") d("*") = "" For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, 3)) = "" Next i Choix = d.keys '================' رقم السيارة ============== Tri Choix, LBound(Choix), UBound(Choix) Dim iTemp As Variant For i = LBound(Choix) To (UBound(Choix) - LBound(Choix)) \ 2 iTemp = Choix(i) Choix(i) = Choix(UBound(Choix) - i) Choix(UBound(Choix) - i) = iTemp Next i Me.ComboBox1.List = Choix '================' اسم السائق ======================== Set d = CreateObject("scripting.dictionary") d("*") = "" For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, 4)) = "" Next i Choix = d.keys Tri Choix, LBound(Choix), UBound(Choix) Me.ComboBox4.List = Choix Set d = CreateObject("scripting.dictionary") colDate = 2 For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, colDate)) = "" Next i Dates = d.keys Tri Dates, LBound(Dates), UBound(Dates) Me.ComboBox2.List = Dates: Me.ComboBox2 = Dates(0) Me.ComboBox3.List = Dates: Me.ComboBox3 = Dates(UBound(Dates)) Filtre End Sub Sub Filtre() Dim tbl() clé = Me.ComboBox1: If clé = "" Then clé = "*" cléLieu = Me.ComboBox4: If cléLieu = "" Then cléLieu = "*" début = CDate(Me.ComboBox2) fin = CDate(Me.ComboBox3) colDate = 2 n = 0 For i = LBound(OnRng) To UBound(OnRng) If OnRng(i, colDate) >= début And OnRng(i, colDate) <= fin And OnRng(i, 3) Like clé And OnRng(i, 4) Like cléLieu Then n = n + 1: ReDim Preserve tbl(1 To Irow, 1 To n) c = 0 For Each K In ColVisu c = c + 1: tbl(c, n) = OnRng(i, K) Next K End If Next i If n > 0 Then Me.ListBox1.Column = tbl Else Me.ListBox1.Clear MsgBox "لم يتم العثور على بيانات مطابقة", vbInformation, "نتائج التصفية" End If End Sub ListBox1.ColumnCount = 12-V2.xlsm

نعم مثلا كومبوبوكس 4 ,و5 يتم تعبئتها من الأعمدة 1,و2 وانت واضع شرط التحقق من قيم العمود D هل هو خطأ ؟ اظافة ان الطريقة المستخدمة في الملف لن تمكنك من عرض أكثر من 10 أعمدة لو وضحت ما تحاول فعله ممكن نعرض البيانات عادي على الليست بوكس وفلترتها بين تاريخين والشروط المطلوبة اذا حددت أعمدتها

وعليكم السلام ورحمة الله تعالى وبركاته قبل الخوض في مسألة عرض الأعمدة أظن أنك بحاجة لمراجعة الشروط على الأكواد التالية For i = 2 To lastRow If (LCase(ws.Cells(i, 3).value) = LCase(searchValue1) Or searchValue1 = "ALL") And _ (LCase(ws.Cells(i, 4).value) = LCase(searchValue2) Or searchValue2 = "ALL") And _ ws.Cells(i, 3).value Like "*" & searchValue1 & "*" And _ (Not includeDates Or (ws.Cells(i, 2) >= DateMin And ws.Cells(i, 2) <= DateMax)) Then '================================================= ' For i = 2 To lastRow If Trim(ws.Cells(i, "b").value) = ComboBox5.value Then ComboBox4.value = ws.Cells(i, "a").value Exit For End If Next i أعتقد ان عناصر combobo4 و combobox 5 يتم تعبئتها بشكل خاطئ يرجى التأكد منها أولا أو تحديد الأعمدة المطلوبة دون الحاجة لإرفاق اي أكواد

وعليكم السلام ورحمة الله تعالى وبركاته عبارة تعديل على الكود تشمل عدة احتمالات المرجوا توضيح طلبك بدقة لنستطيع مساعدتك

العفو أخي @ahmed sewelam يسعدنا أننا إستطعنا مساعدتك ' تحويل القيمة المدخلة الى تاريخ MinDate و MaxDate MinDate = CDate(TextBox1.Value) MaxDate = CDate(TextBox2.Value) ' جلب البيانات من النطاق A3:I a = WS.Range("A3:I" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Value ' قواميس لتخزين البيانات المجمعة ' dc لتخزين صافي المبيعات، dnc لتخزين صافي المردودات، dnc1 لتخزين المندوب Set dc = CreateObject("Scripting.Dictionary") Set dnc = CreateObject("Scripting.Dictionary") Set dnc1 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) 'MinDate و MaxDate إذا كان التاريخ ' (العمود B) a(i, 2)' 'يقع بين If a(i, 2) >= MinDate And a(i, 2) <= MaxDate Then tmp = Trim(a(i, 7)) ' العمود G: "المندوب" ' إذا لم يكن المندوب موجودا مسبقا في القاموس نقوم بإضافته وتخزين القيم المبدئية If Not dc.Exists(tmp) Then dnc1(tmp) = a(i, 6) ' العمود F: "تخزين اسم المندوب" dc(tmp) = a(i, 8) ' العمود H: "تخزين صافي المبيعات" dnc(tmp) = a(i, 9) ' العمود I: "تخزين صافي المردودات" Else ' إذا كان المندوب موجودا إضافة القيم إلى القيم المخزنة dc(tmp) = dc(tmp) + a(i, 8) ' تجميع عدد المبيعات dnc(tmp) = dnc(tmp) + a(i, 9) ' تجميع المردودات End If End If Next i 'إذا كانت القواميس تحتوي على بيانات (dc.Count > 0) ' مطابقة للفترة الزمنية المحددة If dc.Count > 0 Then Application.ScreenUpdating = False 'مسح أي محتوى سابق من النطاق C12:F في ورقة "Report" With dest.Range("C12:F" & dest.Rows.Count) .ClearContents .ClearFormats End With ' تعيين حجم المصفوفة arr بناءا على عدد العناصر في القاموس dc n = 1 ReDim arr(1 To dc.Count, 1 To 4) ' تعبئة المصفوفة For Each key In dc.Keys arr(n, 1) = dnc1(key) ' العمود الأول في arr: "كود" arr(n, 2) = key ' العمود الثاني : "المندوب" arr(n, 3) = dc(key) ' العمود الثالث : "إجمالي المبيعات" arr(n, 4) = dnc(key) ' العمود الرابع : "إجمالي المردودات" n = n + 1 Next key ' نسخ محتويات المصفوفة "Report"(C12) بداية من الخلية dest.Range("C12").Resize(dc.Count, 4).Value = arr ' تحديد الصف الأخير المستخدم بعد إدراج البيانات lastRow = dest.Cells(dest.Rows.Count, "E").End(xlUp).Row ' إضافة "الإجمالي" في العمود D أسفل البيانات dest.Cells(lastRow + 1, "D").Value = "الإجمالي" 'وضع الإجمالي أسفل التقرير ' للأعمدة E و F (صافي المبيعات وصافي المردودات)' For Each col In Array("E", "F") dest.Cells(lastRow + 1, col).Value = Application.WorksheetFunction.Sum(dest.Range(col & "12:" & col & lastRow)) Next col ' يتم وضع تاريخ البداية والنهاية في الخلايا E9 و F9 dest.Range("E9").Value = MinDate dest.Range("F9").Value = MaxDate ' نطاق البيانات في التقرير Set Rng = dest.Range("C12:F" & lastRow) ' إضافة حدود حول كل صف في التقرير يحتوي على بيانات For Each C In Rng.Rows If Application.WorksheetFunction.CountA(C) > 0 Then C.Borders.LineStyle = xlContinuous End If Next C

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Private Sub CommandButton1_Click() Dim MinDate As Date, MaxDate As Date Dim WS As Worksheet, dest As Worksheet Dim a As Variant, tmp As String Dim dc As Object, dnc As Object, dnc1 As Object Dim arr() As Variant, n As Long, lastRow As Long, i As Long Dim Rng As Range, C As Range, col As Variant, key As Variant Set WS = Sheets("DATA"): Set dest = Sheets("Report") If Not IsDate(TextBox1.Value) Or Not IsDate(TextBox2.Value) Then MsgBox "المرجوا التحقق من التواريخ", vbExclamation Exit Sub End If MinDate = CDate(TextBox1.Value) MaxDate = CDate(TextBox2.Value) a = WS.Range("A3:I" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Value Set dc = CreateObject("Scripting.Dictionary") Set dnc = CreateObject("Scripting.Dictionary") Set dnc1 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) If a(i, 2) >= MinDate And a(i, 2) <= MaxDate Then tmp = Trim(a(i, 7)) If Not dc.Exists(tmp) Then dnc1(tmp) = a(i, 6): dc(tmp) = a(i, 8): dnc(tmp) = a(i, 9) Else dc(tmp) = dc(tmp) + a(i, 8): dnc(tmp) = dnc(tmp) + a(i, 9) End If End If Next i If dc.Count > 0 Then Application.ScreenUpdating = False With dest.Range("C12:F" & dest.Rows.Count) .ClearContents: .ClearFormats End With n = 1 ReDim arr(1 To dc.Count, 1 To 4) For Each key In dc.Keys arr(n, 1) = dnc1(key): arr(n, 2) = key: arr(n, 3) = dc(key): arr(n, 4) = dnc(key) n = n + 1 Next key dest.Range("C12").Resize(dc.Count, 4).Value = arr lastRow = dest.Cells(dest.Rows.Count, "E").End(xlUp).Row dest.Cells(lastRow + 1, "D").Value = "الإجمالي" For Each col In Array("E", "F") dest.Cells(lastRow + 1, col).Value = Application.WorksheetFunction.Sum(dest.Range(col & "12:" & col & lastRow)) Next col dest.Range("E9").Value = MinDate: dest.Range("F9").Value = MaxDate Set Rng = dest.Range("C12:F" & lastRow) For Each C In Rng.Rows If Application.WorksheetFunction.CountA(C) > 0 Then C.Borders.LineStyle = xlContinuous End If Next C Else MsgBox "لا توجد بيانات تطابق التواريخ المحددة" End If Application.ScreenUpdating = True End Sub TEST v1.xlsm