محمد هشام.

على حسب ما فهمت من اخر تعديل قمت به داخل الكود تمت تجربة الملف ويشتغل بدون ادنى مشكلة Sub TEST() Dim Réf, A(), i&, F&, Y&, K&, last&, Sh As Variant Dim Dest As Worksheet: Set Dest = Sheets("All_School") last = Dest.Cells(Rows.Count, "b").End(xlUp).Row + 1 Application.ScreenUpdating = False For Each Sh In Sheets(Array("kg1", "kg2", "C1", "C2", "C3", "C4", "C5", "C6")) K = Sh.Range("B" & Rows.Count).End(xlUp).Row Réf = Sh.Range("B6:x" & K) For i = 1 To UBound(Réf, 1) Dest.Range("A6:X" & last).ClearContents Y = Y + 1: ReDim Preserve A(1 To UBound(Réf, 2), 1 To Y) For F = 1 To UBound(Réf, 2) A(F, Y) = Réf(i, F) Next Next With Dest Dest.Range("B6").Resize(Y, UBound(A, 1)) = Application.Transpose(A) End With Next Sh For F = 6 To Dest.Cells(Rows.Count, "B").End(xlUp).Row If Dest.Cells(F, "B").Value <> "" Then Dest.Cells(F, "a").Value = F - 5 End If Next F End Sub test05.xlsm

أخي لقد تم تعديل الملف اكثر من 4 مرات. والان نكتشف أن البيانات حتى العود x !!!!!! 1)هل قمت بتجربة الملف في المرفقات 2) لا يمكنني مساعدتك بدون إرفاق الملف الأصلي أو نسخة طبق الأصل. تفاديا لاهدار الوقت بدون فائدة

تفضل جرب لاكن لازم الاخد بالاعتبار عند تشغيله على ملف اخر يجب عليك تعديل مكان تموضع الشيتات مثلا هنا حددنا من الشيت الاول الى الشيت الثالث في ترتيب اوراق العمل For i = 1 To Sheets.Count - 3 وهنا حددنا من الشيت الرابع الى اخر شيت على الملف المرفق For i = 4 To Sheets.Count يتبقى لك تعديلهم بما يناسيك Sub SAVE_PDF1() 'Save an array of sheets '1/2/3 Dim Path As String Path = ThisWorkbook.Path & "\" Application.ScreenUpdating = False For i = 1 To Sheets.Count - 3 Sheets(i).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & ActiveSheet.Name & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Next MsgBox "تم حفظ الملفات بنجاح" End Sub الكود الثاني Sub SAVE_PDF2() 'Save an array of sheets '4/5/6 Dim Chemin As String Application.ScreenUpdating = False With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False .Title = "اختيار مسار حفظ الملفات" If .Show = -1 Then Chemin = .SelectedItems(1) & "\" Else Exit Sub End If For i = 4 To Sheets.Count Sheets(i).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & ActiveSheet.Name & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Next End With MsgBox "تم حفظ الملفات بنجاح" End Sub احصاء V3.xlsb

نعم اخي يمكننا فعل دالك تفضل Sub All_School() Dim Réf, A(), i&, F&, Y&, K&, last&, Sh As Variant Dim Dest As Worksheet: Set Dest = Sheets("All_School") last = Dest.Cells(Rows.Count, "a").End(xlUp).Row + 1 Application.ScreenUpdating = False ' يمكنك اظافة اسماء اوراق العمل المرغوب جلب البيانات منها بالطريقة التالية ' For Each Sh In Sheets(Array("class1", "class2", "class3", "class4", "class5", "class6")) 'هنا تمت اظافة 3 اوراق فقط للتجربة For Each Sh In Sheets(Array("class1", "class2", "class4")) K = Sh.Range("B" & Rows.Count).End(xlUp).Row Réf = Sh.Range("B5:E" & K) For i = 1 To UBound(Réf, 1) Dest.Range("A5:E" & last).ClearContents Y = Y + 1: ReDim Preserve A(1 To UBound(Réf, 2), 1 To Y) For F = 1 To UBound(Réf, 2) A(F, Y) = Réf(i, F) Next Next With Dest Dest.Range("B5").Resize(Y, UBound(A, 1)) = Application.Transpose(A) End With Next Sh For F = 5 To Dest.Cells(Rows.Count, "B").End(xlUp).Row If Dest.Cells(F, "B").Value <> "" Then Dest.Cells(F, "a").Value = F - 4 End If Next F End Sub تجميع التلاميذ 4.xlsm

تفضل اخي Sub Save_PDF() 'Save an array of sheets '1/2/3 Dim ws As Variant Dim i As Integer, sh As String Path = ThisWorkbook.Path & "\" Application.ScreenUpdating = False Dim weekSheet As Worksheet For Each ws In Sheets(Array("الأول", "الثاني", "الثالث")) With ws .Activate Set weekSheet = ActiveSheet weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & weekSheet.Name & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End With Next For i = 1 To 3 sh = sh & Chr(10) & Chr(10) & ThisWorkbook.Sheets(i).Name Next MsgBox "تم حفظ الملفات بنجاح" & sh, vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "معلومات" Application.ScreenUpdating = True End Sub تفضل استاد Sub Save_PDF2() 'Save an array of sheets '4/5/6 Dim ws As Variant Dim Chemin As String Dim weekSheet As Worksheet With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False .Title = "اختيار مسار حفظ الملفات" If .Show = -1 Then Chemin = .SelectedItems(1) & "\" For Each ws In Sheets(Array("السادس", "الخامس", "الرابع")) With ws .Activate Application.ScreenUpdating = False Set weekSheet = ActiveSheet weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & weekSheet.Name & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End With Next MsgBox (": تم حفظ الملفات بنجاح في " & vbLf & vbLf & vbLf & .SelectedItems(1)), vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "معلومات" Else Exit Sub End If End With Application.ScreenUpdating = True End Sub بالتوفيق .... احصاء V2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته هل الملفات يتم حفظها في ورقة pdf واحدة او كل ورقة مستقلة بداتها

يمكنك استثناء اي ورقة عمل بالطريقة التالية لنفترض اننا اردنا عدم جلب بيانات الورقة 1 والورقة 2 مثلا . If Sheets(sh).Name <> wsData.Name And Sheets(sh).Name <> "ورقة1" And Sheets(sh).Name <> "ورقة2" Then اما بالنسبة لتنسيق عمود المسلسل فقد تمت مراعات دالك داخل الكود Sub All_School() Dim i As Long, sh As Integer, lig As Long, j As Integer Dim wsData As Worksheet: Set wsData = Sheets("All_School") With wsData Application.ScreenUpdating = False .Range("A5:D" & .Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents For sh = 1 To Sheets.Count If Sheets(sh).Name <> wsData.Name And Sheets(sh).Name <> "ورقة1" Then For i = 5 To Sheets(sh).Range("B" & Rows.Count).End(xlUp).Row + 1 If .Range("B5") = "" Then lig = 5 Else lig = .Range("B" & Rows.Count).End(xlUp).Row + 1 For j = 2 To .Cells(4, Columns.Count).End(xlToLeft).Column .Cells(lig, j) = Sheets(sh).Cells(i, j) For F = 5 To wsData.Cells(Rows.Count, "B").End(xlUp).Row If wsData.Cells(F, "B").Value <> "" Then wsData.Cells(F, "a").Value = F - 4 End If Next F Next Next End If Next End With End Sub تجميع التلاميذ 3.xlsm

هدا بسبب عدم تفريغك للبيانات القديمة لقد تم تزويدك من قبل باكواد اسرع واسهل من هدا بكثير على العموم تفضل تم تعديل المرفق كل عام وانت بخير (2).xlsm

اخي ملفك مليئ بالاخطاء وغير منظم لاكنني ساقوم باصلاح كود الترحيل فقط على حسب طلبك بنفس طريقة اشتغالك قم بوضع الكود هكدا . Private Sub CmdADD_Click() Dim last As Long If Me.TextBox2 = Empty Then: Exit Sub With sheet1 last = .Cells(.Rows.Count, "b").End(xlUp).Offset(1, 0).Row sheet1.Cells(last, "B").Value = Me.TextBox2.Value ' الرقم التعريفي sheet1.Cells(last, "C").Value = Me.TextBox15.Value 'الرقم التسجيل sheet1.Cells(last, "E").Value = Me.TextBox8.Value ' اللقب sheet1.Cells(last, "D").Value = Me.TextBox16.Value 'الاسم sheet1.Cells(last, "G").Value = Me.TextBox10.Value 'مكان الميلاد sheet1.Cells(last, "F").Value = Me.TextBox11.Value 'تاريخ الميلاد sheet1.Cells(last, "AE").Value = Me.TextBox9.Value 'اللقب بالاتننية sheet1.Cells(last, "AF").Value = Me.TextBox17.Value 'الاسم بالاتننية sheet1.Cells(last, "AG").Value = Me.TextBox18.Value 'مكان الميلاد بالاتننية sheet1.Cells(last, "AH").Value = Me.TextBox19.Value 'ولاية sheet1.Cells(last, "AC").Value = Me.TextBox12.Value 'تخصص sheet1.Cells(last, "AD").Value = Me.TextBox20.Value 'تخصص بالاتننية sheet1.Cells(last, "AI").Value = Me.TextBox13.Value ' رقم الوسيط sheet1.Cells(last, "AJ").Value = Me.TextBox21.Value ' رقم هاتف End With Me.TextBox2.Value = "" Me.TextBox15.Value = "" Me.TextBox16.Value = "" Me.TextBox8.Value = "" Me.TextBox10.Value = "" Me.TextBox11.Value = "" Me.TextBox9.Value = "" Me.TextBox17.Value = "" Me.TextBox18.Value = "" Me.TextBox19.Value = "" Me.TextBox12.Value = "" Me.TextBox20.Value = "" Me.TextBox13.Value = "" Me.TextBox21.Value = "" MsgBox "تم ترحيل البيانات بنجاح", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "تأكيد" ThisWorkbook.Save End Sub

صراحة لم افهم مادا تقصد يمكنك ارفاق عينة للنتيجة المطلوبة ادا امكن . اظافة لا يوجد اي جدول باسم معرف على الملف اما ادا كنت تقصد ترتيبها بنفس التسلسل الموجود على كل ملف تم تغييره بتسلسل جديد ليتوافق مع شكل الملف لديك في اول مشاركة على العموم ادا كان هدا هو طلبك اجعل الكود بهده الطريقة Sub importer() Dim i As Long, sh As Integer, lig As Long, j As Integer Dim wsData As Worksheet: Set wsData = Sheets("الجميع") With wsData Application.ScreenUpdating = False .Range("A5:D" & .Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents For sh = 1 To Sheets.Count If Sheets(sh).Name <> wsData.Name Then For i = 5 To Sheets(sh).Range("a" & Rows.Count).End(xlUp).Row + 1 If .Range("a5") = "" Then lig = 5 Else lig = .Range("a" & Rows.Count).End(xlUp).Row + 1 For j = 1 To .Cells(4, Columns.Count).End(xlToLeft).Column .Cells(lig, j) = Sheets(sh).Cells(i, j) Next Next End If Next End With End Sub واي اضافة او تعديل لا تتردد في دكره سوف نكون سعداء لمساعدتك بالتوفيق..

وعليكم السلام ورحمة اله تعالى وبركاته تفضل اخي Sub importer() Dim i As Long, sh As Integer, lig As Long, j As Integer Dim wsData As Worksheet: Set wsData = Sheets("الجميع") With wsData Application.ScreenUpdating = False .Range("A5:D" & .Range("A" & Rows.Count).End(xlUp).Row + 1).ClearContents For sh = 1 To Sheets.Count If Sheets(sh).Name <> wsData.Name Then For i = 5 To Sheets(sh).Range("B" & Rows.Count).End(xlUp).Row + 1 If .Range("B5") = "" Then lig = 5 Else lig = .Range("B" & Rows.Count).End(xlUp).Row + 1 For j = 2 To .Cells(4, Columns.Count).End(xlToLeft).Column .Cells(lig, j) = Sheets(sh).Cells(i, j) [A5] = 1 Range("a5:a" & Range("b" & Rows.Count).End(xlUp).Row).DataSeries , xlDataSeriesLinear Next Next End If Next End With End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'لجلب البيانات تلقائيا يمكنك وضع هدا الرمز في حدث شيت الجميع Private Sub Worksheet_Activate() Call importer End Sub ملاحظة قد تم وضعه مسبق يكفي فقط تفعيله في حالة الرغبة عن الاستغناء عن الزر لتنفيد الكود v2 تجميع التلاميذ.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته ما عليك سوى تحديد الشيتات المرغوب دمجها كما في الصورة Sub Merge_worksheets() Dim Rng, C, A(), P&, i&, F&, Y&, N&, derligne&, lastrow& Dim DestArr() As String Dim ws As Worksheet: Set ws = Sheets("تجميع") lastrow = ws.Cells(Rows.Count, "a").End(xlUp).Row + 1 N = ws.Range("W" & Rows.Count).End(xlUp).Row Set Rng = ws.Range("W2:W" & N) Application.ScreenUpdating = False If ws.[V2] = Empty Then m = MsgBox("المرجوا تحديث قائمة أسماء الشيتات", vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "انتباه"): Exit Sub On Error Resume Next For Each C In Rng If C Then If C <> "" Then ReDim Preserve DestArr(0 To P) DestArr(P) = C.Offset(, -1).Value P = P + 1 End If End If Next For K = LBound(DestArr) To UBound(DestArr) Worksheets(DestArr(K)).Activate derligne = ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row Rng = ActiveSheet.Range("A5:N" & derligne) For i = 1 To UBound(Rng, 1) ws.Range("A2:N" & lastrow).ClearContents Y = Y + 1: ReDim Preserve A(1 To UBound(Rng, 2), 1 To Y) For F = 1 To UBound(Rng, 2) A(F, Y) = Rng(i, F) Next Next With ws ws.Range("a2").Resize(Y, UBound(A, 1)) = Application.Transpose(A) End With Next On Error GoTo 0 ws.Activate End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub ListSheets() Dim derligne&, x As Integer Dim ws As Worksheet: Set ws = Sheets("تجميع") derligne = ws.Cells(Rows.Count, 22).End(xlUp).Row + 1 Application.ScreenUpdating = False ws.Range("v2:v" & derligne).ClearContents x = 2 For Each WSdata In Worksheets If WSdata.Name <> ws.Name Then ws.Cells(x, 22) = WSdata.Name x = x + 1 End If Next End Sub تجميع V2.xlsm

لابد من تزويدنا بعينة من شكل الملفات المرغوب طباعتها او جرب استخدام خاصية Shell "wiaacmgr.exe", vbNormalFocus يمكنك البحث عنها في النت في ظل غياب المعطيات الكافية ساحاول الانتقال للطلب الثاني والثالث بالنسبة لامكانية عرض بيانات جداول مختلفة والتنقل بينها على نفس الليست بوكس تفضل اخي Dim TB1, f, b, R, Z, Rng, WSData, WS, WS1, WS2() Private Sub UserForm_Initialize() If WS = "" Then Me.ComboBox1.clear For s = 1 To Sheets.Count For Each n In Sheets(s).ListObjects Me.ComboBox1.AddItem n.Name Next n Next s Me.ComboBox1.ListIndex = 0 If TB1 = "" Then TB1 = Me.ComboBox1 Else TB1 = WS WS2 = Array(1, 2, 3, 4, 5, 6) Z = Array(1, 2, 3, 4, 5, 6) R = UBound(WS2) + 1 b = UBound(Z) + 1 Me.ListBox1.ColumnCount = WSData + 1 End If ST End Sub Private Sub ComboBox1_click() TB1 = Me.ComboBox1 Select Case TB1 Case Is = "الصادر" WS2 = Array(1, 2, 3, 4, 5, 6) Z = Array(1, 2, 3, 4, 5, 6) Case Is = "الوارد" WS2 = Array(1, 2, 3, 4, 5, 6) Z = Array(1, 2, 3, 4, 5, 6) End Select WS = Me.ComboBox1 WSData = Range(TB1).Columns.Count R = UBound(WS2) + 1 b = UBound(Z) + 1 ST End Sub Sub ST() WSData = Range(TB1).Columns.Count Rng = Range(TB1).Resize(, WSData + 1).Value For i = 1 To UBound(Rng): Rng(i, WSData + 1) = i: Next i Tb_Text For i = WSData + 1 To 6: Me("textbox" & i).Visible = False: Next i For i = WSData + 1 To 6: Me("label" & i).Visible = False: Next i For i = LBound(Rng) To UBound(Rng): Rng(i, 3) = Format(Rng(i, 3), "dd/mm/yyyy"): Next i ReDim WS1(1 To UBound(Rng)) col = UBound(Rng, 2) For i = LBound(Rng) To UBound(Rng) For Each K In WS2 WS1(i) = WS1(i) & Rng(i, K) & "|" Next K WS1(i) = WS1(i) & Rng(i, col) & "|" Next i Dim TBL(): ReDim TBL(1 To UBound(Rng), 1 To WSData + 1) For i = 1 To UBound(Rng) For c = 1 To WSData: TBL(i, c) = Rng(i, c): Next c TBL(i, c) = Rng(i, WSData + 1) Next i Me.ListBox1.List = TBL Me.ListBox1.ListIndex = -1 Empty_wsData_Click Me.Text_Rech.SetFocus End Sub جاري التعديل (2).xlsm

موضوع مكرر

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub CommandButton1_Click() TextBox2.Value = Format(Range("A2").Value, "dd/mm/yyyy") End Sub

حل اخر في حالة الرغبة بمسح البيانات القديمة وترحيل الجديدة Sub Sheets_Arrays2() ' بالتنسيقات Dim LR&, LR2&, lrow& Dim wsData As Variant Dim Dest As Worksheet: Set Dest = Sheets("eman") lRow = Dest.Cells(Dest.Rows.Count, "C").End(xlUp).Offset(1).Row Application.ScreenUpdating = False Dest.Range("C10:J" & lRow).ClearContents For Each wsData In Sheets(Array("Sheet1", "Sheet2", "Sheet3")) a = wsData.Cells(Rows.Count, "E").End(xlUp).Row b = Dest.Cells(Rows.Count, "C").End(xlUp).Row wsData.Range("E10:F" & a).Copy Dest.Range("C" & b + 1) wsData.Range("H10:H" & a).Copy Dest.Range("E" & b + 1) wsData.Range("J10:J" & a).Copy Dest.Range("F" & b + 1) wsData.Range("L10:M" & a).Copy Dest.Range("G" & b + 1) wsData.Range("P10:Q" & a).Copy Dest.Range("I" & b + 1) Application.ScreenUpdating = True Next wsData End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' قيم Sub Sheets_Arrays3() Dim LR&, LR2& Dim wsData As Variant Dim Dest As Worksheet: Set Dest = Sheets("eman") lrow = Dest.Cells(Dest.Rows.Count, "C").End(xlUp).Offset(1).Row Application.ScreenUpdating = False Dest.Range("C10:J" & lrow).ClearContents For Each wsData In Sheets(Array("sheet1", "sheet2", "sheet3")) LR = wsData.Cells(Rows.Count, "E").End(xlUp).Row LR2 = Dest.Cells(Rows.Count, "C").End(xlUp).Row + 1 With wsData Dest.Range("C" & LR2 & ":d" & LR2 + LR - 10).Value = wsData.Range("E10:F" & LR).Value Dest.Range("E" & LR2 & ":e" & LR2 + LR - 10).Value = wsData.Range("H10:H" & LR).Value Dest.Range("F" & LR2 & ":F" & LR2 + LR - 10).Value = wsData.Range("J10:J" & LR).Value Dest.Range("G" & LR2 & ":h" & LR2 + LR - 10).Value = wsData.Range("L10:M" & LR).Value Dest.Range("I" & LR2 & ":j" & LR2 + LR - 10).Value = wsData.Range("P10:Q" & LR).Value End With Application.ScreenUpdating = True Next wsData End Sub عيد مبارك سعيد2.xlsm

تفضل اخي لاظهار اسماء اوراق العمل او اخفائها استخدم الكود التالي Sub Show_and_hide_sheets() If ActiveWindow.DisplayWorkbookTabs = False Then ActiveWindow.DisplayWorkbookTabs = True Else ActiveWindow.DisplayWorkbookTabs = False End If End Sub

وعليكم السلام ورحمة الله تعالى وبركاته Sub Sheets_Arr() Dim a, b, C As Variant, lr& Dim Dest As Worksheet: Set Dest = Sheets("eman") 'Columns : E,F,H,L,M,P,Q Const r As String = "5 6 8 10 12 13 16 17 " For Each C In Sheets(Array("Sheet1", "Sheet2", "Sheet3")) lastrow = Dest.Cells(Dest.Rows.Count, "C").End(xlUp).Row + 1 Application.ScreenUpdating = False lr = C.Columns("A:Q").Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row a = Evaluate("row(10:" & lr + 10 & ")") b = Split(r) Dest.Range("c" & lastrow).Resize(lr, UBound(b)).Value = Application.Index(C.Cells, a, b) Application.ScreenUpdating = True Next C End Sub عيد مبارك سعيد.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Sub Filtre() Dim ws1 As Worksheet: Set ws1 = Sheets("Raw Data") Dim ws2 As Worksheet: Set ws2 = Sheets("list filter") Application.ScreenUpdating = False On Error Resume Next ws1.ShowAllData '(B)'المعيار الاول عمود '--- Iso_Spool n = Application.CountA(ws2.Range("A2:A5")) If n > 0 Then Tbl = Application.Transpose(ws2.[A2].Resize(n)) ws1.[A4].AutoFilter Field:=2, Criteria1:=Tbl, Operator:=xlFilterValues End If '(C)'المعيار الثاني عمود '--- Spool2 n = Application.CountA(ws2.Range("B2:B5")) If n > 0 Then Tbl = Application.Transpose(ws2.[B2].Resize(n)) ws1.[A4].AutoFilter Field:=3, Criteria1:=Tbl, Operator:=xlFilterValues End If '(E)'المعيار الثالث عمود '--- IdentCode n = Application.CountA(ws2.Range("C2:C5")) If n > 0 Then Tbl = Application.Transpose(ws2.[C2].Resize(n)) ws1.[A4].AutoFilter Field:=5, Criteria1:=Tbl, Operator:=xlFilterValues End If End Sub TEST V3.xlsm

clé هو نطاق وضع معايير الفلترة اما بخصوص فلترة البيانات بشرط عدة اعمدة نعم يمكنك دالك لاكن هدا لم يكن ضمن طلبك اول مرة خاصة انك طلبت فقط تعديل الكود المرفق.و لكي لا تتداخل المواضيع في بعضها البعض ربما تحتاج لفتح موضوع جديد بطلبك وسوف نكون سعداء بمساعدتك .

أعتذر السبب هو الفرق في تنسيق التاريخ وتقويم اللغة على الجهاز قم بتغييرها فقط إلى =IF($F$10<>"";"30/"&TEXT($F$10;"mm/aaaa");"") طلبك يتمثل في كتابة اي تاريخ بالنسبة لاقتراح الاخ @أبوأحـمـد ممكن يفيدك لاكن مشكلته عند تغيير التاريخ الى شهر 2 لن يشتغل معك بالشكل الصحيح .عكس المعادلة الأولى DATE 30-2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته =IF($F$10<>"";"30/"&TEXT($F$10;"mm/aaaa");"") ");"") اخر يوم في الشهر =EOMONTH($F$10;0)

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

إليك حل اخر لفلترة البيانات بعدة معايير Option Explicit Public Sub Filter_data() Dim lo As ListObject, rng As Range Dim rw As Long, i As Long Dim arrayCriteria() Set lo = Range("Clé").ListObject rw = lo.ListRows.Count ReDim arrayCriteria(rw) For i = 1 To rw arrayCriteria(i) = CStr(lo.DataBodyRange.Cells(i, 1)) Next i Set rng = Range("Tbl") With rng.ListObject If .ShowAutoFilter Then .AutoFilter.ShowAllData .Range.AutoFilter field:=2, Criteria1:=arrayCriteria, Operator:=xlFilterValues End With End Sub '''''''''''''''''''''''''''''''''''''''''' Public Sub Reset_filter() Dim rng As Range Set rng = Range("Tbl") With rng.ListObject If .ShowAutoFilter Then .AutoFilter.ShowAllData End With End Sub TEST V2.xlsm

تفضل جرب اخي فلترة البيانات بقيمة الخلية (A1) يمكنك استخدام الكود التالي Sub Filter_Data() Dim Rng As Range Dim Crite As Worksheet: Set Crite = Sheets("Raw Data") Dim CFilter As Worksheet: Set CFilter = Sheets("Do Not Include") lrow = Crite.Range("B" & Rows.Count).End(xlUp).Row Réf = CFilter.[A1] On Error Resume Next If Réf = Empty Then: Exit Sub Crite.AutoFilter.ShowAllData Set Rng = Crite.Range("B6:B" & lrow).Find("*", Réf, LookIn:=XlFindLookIn.xlFormulas, _ lookat:=xlWhole, _ SearchDirection:=xlPrevious) Application.ScreenUpdating = False Crite.Range("A4:E" & lrow).AutoFilter Field:=2, Criteria1:=Réf Crite.Activate On Error GoTo 0 Application.ScreenUpdating = True End Sub test 8.xlsm