محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub مناداة_4() Dim wb As Workbook, wsData As Worksheet, wsDest As Worksheet Dim arr As Variant, k As Variant, Col As Variant, r As Long Set wb = ThisWorkbook: Set wsData = wb.Sheets("control4"): Set wsDest = wb.Sheets("مناداة4") arr = wsData.Range("C10:U" & wsData.Cells(Rows.Count, 6).End(xlUp).Row).Value2 Application.ScreenUpdating = False wsDest.Range("l5:W1000").ClearContents Col = Array(12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23) For Each k In Array(1, 3, 4, 8, 10, 11, 14, 15, 16, 17, 18, 19) wsDest.Cells(5, Col(r)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , k) r = r + 1 Next k Application.ScreenUpdating = True End Sub مصطفي - 2.xlsb

تفضل اخي تم اظافة ورقة مخفية لعرض الملفات الموجودة داخل المجلد على الليست بوكس واستخراج وطباعة اسماء التقارير الغير مرفوعة 'Private Sub UserForm_Initialize() اظافة في nomPDF = "Tableau1" Réf = Range(nomPDF).Columns.Count List = Range(nomPDF).Resize(, Réf + 1).Value For i = 1 To UBound(List): Next i ''''''''''''''''''''''''''''''''' Private Sub Recherche_Change() ling1 = 1 ling2 = 2 clé = "*" & Me.Recherche & "*": n = 0 Dim Tbl() For i = 1 To UBound(List) On Error Resume Next If List(i, ling1) Like clé Or List(i, ling2) Like clé Then n = n + 1: ReDim Preserve Tbl(1 To 2, 1 To n) Tbl(1, n) = List(i, ling1): Tbl(2, n) = (Format((List(i, ling2)), "dd/mm/yyyy hh:mm")) End If Next i If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.Clear Counter = "عدد التقارير " & "/" & ListBox1.ListCount End Sub بالتوفيق.....🫡 الملف بعد التعديل 3.xls تقرير الحالات.rar

Sub test() Dim j(1 To 2) As String Dim WSData As Worksheet: Set WSData = Sheets("البداية") Dim F As Variant: Set r = WSData.Range("E7:E" & Range("E" & Rows.Count).End(xlUp).Row) Dim arr() As Variant: arr = r.Value2: F = r.Offset(, 8).Value2 Dim col() As Variant: ReDim col(1 To UBound(arr), 1 To 1) j(1) = Application.ActiveWorkbook.Path & "\تقرير الحالات\" j(2) = Dir(j(1)) If j(2) = "" Then MsgBox "يتعدر العثور على مجلد تقرير الحالات ", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" Else Application.ScreenUpdating = False WSData.Range("F7", Range("F" & Rows.Count).End(4)).ClearContents With CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr) If VBA.Len(F(i, 1)) > 0 And (arr(i, 1)) > 0 Then If Not .Exists(arr(i, 1)) Then .Add arr(i, 1), 1 col(i, 1) = arr(i, 1) Else .Item(arr(i, 1)) = .Item(arr(i, 1)) + 1 col(i, 1) = arr(i, 1) & " (" & .Item(arr(i, 1)) & ")" End If End If Next i r.Offset(, 1).Value2 = col End With Application.ScreenUpdating = True End If End Sub

بعد ادن الاخ المحترم @محي الدين ابو البشر تفضل اخي الكريم تم الاشتغال على اخر نسخة قمت برفعها داخل المشاركة لتحديث ارقام الملفات قم بتشغيل الكود التالي Sub test() Dim j(1 To 2) As String Dim WSData As Worksheet: Set WSData = Sheets("البداية") Dim R As Range: Set R = WSData.Range("E7:E" & Range("E" & Rows.Count).End(xlUp).Row) Dim AR() As Variant: AR = R.Value2 Dim col() As Variant: ReDim col(1 To UBound(AR), 1 To 1) j(1) = Application.ActiveWorkbook.Path & "\تقرير الحالات\" j(2) = Verification j(2) = Dir(j(1)) If j(2) = "" Then ' التحقق من وجود المجلد MsgBox "يتعدر العثور على مجلد تقرير الحالات ", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" Else Application.ScreenUpdating = False Range("F7", Range("F" & Rows.Count).End(4)).ClearContents 'ترقيم الحالات المكررة With CreateObject("Scripting.Dictionary") For i = 1 To UBound(AR) If Not .Exists(AR(i, 1)) Then .Add AR(i, 1), 1 col(i, 1) = AR(i, 1) Else .Item(AR(i, 1)) = .Item(AR(i, 1)) + 1 col(i, 1) = AR(i, 1) & " (" & .Item(AR(i, 1)) & ")" End If Next i '(F) عمود R.Offset(, 1).Value2 = col End With End If Application.ScreenUpdating = True End Sub وفي حدث ورقة البداية ضع الكود التالي تم اظافة رسائل اشعار عند التحقق من عدم وجود مجلد التقارير او عدم وجود رقم التقرير مسبقا داخل المجلد للتجربة يمكنك اما كتابة رقم عشوائي على عمود f او تغيير اسم اي ملف داخل المجلد 😉 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim sh As Worksheet: Set sh = Sheets("البداية") Dim a(1 To 5) As String, FSO As Object, lastrow& lastrow = sh.Columns("F:F").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1 a(1) = Application.ActiveWorkbook.Path & "\تقرير الحالات\" a(2) = Search_File: a(3) = réf Cancel = True If Not Intersect(Target, sh.Range("F7:F" & lastrow)) Is Nothing Then If Target.Value = "" Then Exit Sub PDFname = Target.Value: a(2) = PDFname & ".pdf" Set FSO = CreateObject("Scripting.FileSystemObject") a(3) = GetFiles(FSO, a(1), a(2)): a(4) = a(1) & Target.Value & ".pdf" ' التحقق من وجود اسم الملف داخل المجلد If a(3) = "" Then a(5) = " الملف رقم" & " / " & PDFname & " " & " غير موجود " _ & Chr(10) & Chr(10) _ & "" _ MsgBox a(5), vbInformation, "Admin" Exit Sub End If If Dir(a(4)) <> vbNullString Then On Error Resume Next ActiveWorkbook.FollowHyperlink a(4) On Error GoTo 0 End If End If End Sub Public Function GetFiles(ByVal FSO As Object, ByVal Search_Folder As String, ByVal Search_File As String) As String Dim réf1 As Object, réf2 As Object, réf3 As Object If FSO.FolderExists(Search_Folder) Then Set réf2 = FSO.GetFolder(Search_Folder) For Each réf1 In réf2.Files If LCase(réf1.Name) = LCase(Search_File) Then GetFiles = réf1.Path Exit Function End If Next réf1 For Each réf3 In réf2.SubFolders GetFiles = GetFiles(FSO, réf3.Path, Search_File) If GetFiles <> "" Then Exit Function End If Next réf3 End If End Function بالتوفيق... الملف بعد التعديل 2.xls وهده نفس النسخة مع اظافة يوزرفورم لعرض التقارير المسجلة من داخل المجلد مع امكانية فتح الملف او الحفظ وكدالك الطباعة الملف الاصلى والتقارير.rar

نفس معادلة استادنا الفاضل @محمد حسن المحمد =AVERAGEIFS($E$3:E$11;$C$3:C$11;">="&C15;$C$3:C$11;"<"&EOMONTH(C15;0))

Private Sub Workbook_Open() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets ws.Protect UserInterfaceOnly:=True, Password:="1234" Next ws End Sub

ربما =TEXTJOIN("";1;MID(A1;SEQUENCE(LEN(A1);;LEN(A1);-1);1)) =TEXTJOIN("";1;MID(A1;ABS(ROW(INDIRECT("1:"&LEN(A1)))-(LEN(A1)+1));1))

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub CommandButton1_Click() Const TableName As String = "Table5" Const WSdest As String = "Client ACC" Dim StartDate&, EndDate&, LastRow&, Col& Dim Tb1 As ListObject, rng As Range, Customer As String Set Tb1 = Range(TableName).ListObject Customer = Worksheets(WSdest).[H2] StartDate = DateSerial(Year(Date), Month(Date), Day(Date) - 100) EndDate = DateSerial(Year(Date), Month(Date), Day(Date) + 1) Application.ScreenUpdating = False If Me.ComboBox1.Value = "" Then: MsgBox "أختار أسم العميل حتي يمكنك عرض كشف الحساب", vbCritical, "Ah Med": Exit Sub fc = Application.WorksheetFunction.CountIf(DA.Range("B5:B1000"), Me.ComboBox1.Value) fm = Application.WorksheetFunction.CountIf(DA.Range("I5:I1000"), Me.ComboBox1.Value) If fc <= 0 And fm <= 0 Then: MsgBox "أسم العميل غير موجود ", vbCritical, "Ah Med": Exit Sub With Worksheets(WSdest) LastRow = .Cells(.rows.Count, "E").End(xlUp).Row .Range("E17:R" & LastRow).ClearContents .Range("G11:k11,k14").ClearContents .[H2] = Me.ComboBox1.Value: .[G2] = Format(StartDate): .[F2] = Format(EndDate) End With With Tb1 .Range.AutoFilter field:=2, _ Criteria1:=">=" & StartDate, _ Operator:=xlAnd, _ Criteria2:="<=" & EndDate .Range.AutoFilter field:=5, Criteria1:=Me.ComboBox1.Value On Error Resume Next Set rng = Union(.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible), _ .ListColumns(2).DataBodyRange.SpecialCells(xlCellTypeVisible), _ .ListColumns(3).DataBodyRange.SpecialCells(xlCellTypeVisible), _ .ListColumns(6).DataBodyRange.SpecialCells(xlCellTypeVisible), _ .ListColumns(7).DataBodyRange.SpecialCells(xlCellTypeVisible), _ .ListColumns(8).DataBodyRange.SpecialCells(xlCellTypeVisible), _ .ListColumns(9).DataBodyRange.SpecialCells(xlCellTypeVisible)) End With rng.Copy Worksheets(WSdest).[E17].PasteSpecial xlPasteValuesAndNumberFormats [E16].Select Application.CutCopyMode = False Tb1.ShowAutoFilter = False '===== sum total ========= With Worksheets(WSdest) Col = .Cells(.rows.Count, "E").End(xlUp).Row .[G11] = Application.WorksheetFunction.Sum(Range("H17:H" & Col)) .[H11] = Application.WorksheetFunction.Sum(Range("I17:I" & Col)) .[I11] = Application.WorksheetFunction.Sum(Range("J17:J" & Col)) .[J11] = Application.WorksheetFunction.Sum(Range("K17:K" & Col)) .[K11] = .[H11] + .[I11] + .[J11]: .[K14] = .[G11] - .[K11] End With Application.ScreenUpdating = True End Sub Storm - نسخة.rar

وعليكم السلام ورحمة الله تعالى وبركاته Sub test() Dim j, F, Fin&, i&, R& Dim Tb1 As Worksheet: Set Tb1 = Worksheets("control1") Dim Tb2 As Worksheet: Set Tb2 = Worksheets("تقييم عام") F = 1: j = 12 Application.ScreenUpdating = False For Fin = 10 To Tb1.Cells(Tb1.Rows.Count, "c").End(xlUp).Row If Tb1.Range("C" & Fin) <> "" Then Tb2.Range("D" & j) = Tb1.Range("C" & Fin): Tb2.Range("E" & j) = Tb1.Range("E" & Fin) Tb2.Range("F" & j) = Tb1.Range("G" & Fin): Tb2.Range("G" & j) = Tb1.Range("K" & Fin) Tb2.Range("H" & j) = Tb1.Range("L" & Fin) If F = 25 Then j = j + 8: F = 1 Else j = j + 1: F = F + 1 End If End If Next R = 1 For Col = 12 To Tb2.Range("D" & Tb2.Rows.Count).End(xlUp).Row If Tb2.Range("D" & Col) <> "" Then: Tb2.Range("C" & Col) = R: R = R + 1 If R = 26 Then: R = 1 Next Col Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله تعالى وبركاته تطبيق على مثالك =IF(AND(A1>=1;A1<=20);1;IF(AND(A1>=21;A1<=31);2;""))

ادن جرب الكود التالي ربما يؤدي المطلوب Sub test() Dim WS As Worksheet: Set WS = ActiveSheet Dim pages As Integer pages = WS.Range("C10") With WS .PageSetup.PrintArea = "$B$2:$D$7" .PrintOut Copies:=pages, Collate:=True End With End Sub نموذج طباعة 3.xlsm

بالرغم انني لا اعلم عن طريقة اشتغالك على الملف لاكن اليك طريقة اخرى ربما تفيدك الطريقة كالتالي https://streamable.com/1kukv8 Public Property Get Sh_Print() As Worksheet: Set Sh_Print = Sheet1 End Property Public Property Get Sh_Table() As Worksheet: Set Sh_Table = Sheet2 End Property Sub To_print() TbPage = Sh_Table.[Tb_MiseEnPage] NbMax = UBound(TbPage) Cpt = Application.InputBox(Prompt:=" المرجوا ادخال رقم الستيكر المرغوب طباعتها (من 0 الى " & NbMax & ")", Title:="طباعة", Type:=1) Cpt = Int(Cpt) If Cpt < 1 Then Exit Sub If Cpt > NbMax Then: MsgBox "اخر سكيرت على الملف هي :" & " " & NbMax, vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "تنبيه": Exit Sub With Sh_Print .PageSetup.PrintArea = "" For i = 1 To Cpt With .PageSetup .PrintArea = TbPage(i, 7) & ":" & TbPage(i, 8) Copies = TbPage(i, 6) If Copies < 1 Then Copies = 1 .FitToPagesWide = 1 .FitToPagesTall = 1 End With Next End With Sh_Print.PrintOut Copies:=Copies End Sub نموذج طباعة.xlsm

فقط مجرد احتمال على العموم وفقنا الله واياكم لما يحب ويرضى كود جميل ومختصر .شكرا لك

جرب هدا على ما اظن بعد تعيين حدود الطباعة بالشكل الدي يناسبك Sub test() ActiveSheet.PrintOut Copies:=ActiveSheet.Range("c10").Value, IgnorePrintAreas:=False End Sub

Option Explicit Public Property Get WSData() As Worksheet: Set WSData = Sheets("ورقة1") End Property Public Property Get WSDest() As Worksheet: Set WSDest = Sheets("ورقة2") End Property '***' اظافة مربعات الاختيار عند التحقق من وجود قيمة في عمود الاسم Sub Add_CheckBoxes() Dim cell, col As Single, Cpt As CheckBox Dim MyLeft, MyTop, MyHeight, MyWidth As Double Application.ScreenUpdating = False col = WSData.Range("B" & Rows.Count).End(xlUp).Row WSData.CheckBoxes.Delete For cell = 2 To col If WSData.Cells(cell, "B").Value <> "" Then MyLeft = Cells(cell, "A").Left: MyTop = Cells(cell, "A").Top MyHeight = Cells(cell, "A").Height: MyWidth = Cells(cell, "A").Width WSData.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select With Selection .Caption = "": .Value = xlOff: .Display3DShading = False End With [A1].Select End If Next cell Application.ScreenUpdating = True End Sub '**** نسخ الاعمدة المحددة Sub CopyRows() Dim derlig&, r&, Lr&, Cpt As CheckBox For Each Cpt In WSData.CheckBoxes If Cpt.Value = 1 Then For r = 1 To Rows.Count If Cells(r, 1).Top = Cpt.Top Then With WSDest .Range("A2:A" & Rows.Count).ClearContents Lr = .Range("B" & Rows.Count).End(xlUp).Row + 1 ' عمود الاسم .Range("B" & Lr) = _ WSData.Range("B" & r).Value 'في حالة الرغبة بنسخ عدة اعمدة قم بظبط السطر التالي بما يناسبك ' .Range("B" & Lr & ":F" & Lr) = _ ' WSData.Range("B" & r & ":F" & r).Value '**** تسلسل البيانات المنسوخة derlig = WSDest.Range("B" & WSDest.Rows.Count).End(xlUp).Row WSDest.Range("A2").Value = 1 WSDest.Range("A2:A" & derlig).DataSeries , xlDataSeriesLinear End With Exit For End If Next r End If Next On Error Resume Next WSData.CheckBoxes.Value = False On Error GoTo 0 End Sub Microsoft Excel Worksheet جديد (2).xlsm

ربما تحتاج الى تفعيل وحدات الماكرو لديك على العموم هل تريد نسخ عمود الاسم فقط مع مزيدا من التوضيح هل البيانات المنسوخة يتم الاحتفاظ بها رغم الغاء التحديد او حدفها هل تريد مثلا تحديد عدة صفوف وترحيلها دفعة واحدة

بارك الله فيك اخي @محي الدين ابو البشر لاكن يجب أخذ في عين الإعتبار وجود نفس القيمة مكررة في أكثر من خلية على ما أظن

وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب اخي Sub FindCouleur() Dim j(1 To 2) As String, F As Variant Dim a As Range, R As Range, T&, Cpt&, lCol&, lrow& Dim WS As Worksheet: Set WS = Worksheets("0") Application.ScreenUpdating = False lrow = WS.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lCol = WS.Cells(1, Columns.Count).End(xlToLeft).Column j(1) = [Al14]: j(2) = [Al15] Set a = WS. _ Range("A1", WS.Cells(lrow, lCol)) F = Array(j(1), j(2)) With a .Interior.ColorIndex = xlNone For Cpt = LBound(F) To UBound(F) Set R = .Cells(.Cells.Count) For T = 1 To WorksheetFunction.CountIf(a, F(Cpt)) Set R = .Cells.Find(What:=F(Cpt), LookIn:=xlValues, LookAt:=xlWhole, _ After:=R, MatchCase:=False) R.Interior.Color = vbYellow Next T Next End With Application.ScreenUpdating = True End Sub أرقام.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ربما هدا ما تقصد https://streamable.com/lrih4i في الخلية B5 =A2 في الخلية B6 مع السحب للاسفل للحصول على التواريخ =IF(ROW(B1)>=$B$2;"";EDATE($B$5;ROW(B1)*12)) وفي الخلية A5 مع السحب للاسفل للحصول على التسلسل =IF(B5<>"";ROWS($B$1:B1);"") توزيع التاريخ 2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ربما تقصد جمع قيم العمود بشرط الخلفية الزرقاء تفضل جرب وضع هدا لكود في موديول Function TotalRng(SumRange As Range, SumColor As Range) Dim SumColorValue As Integer Dim SumRng As Long SumColorValue = SumColor.Interior.ColorIndex Set b = SumRange For Each b In SumRange If b.Interior.ColorIndex = SumColorValue Then SumRng = SumRng + b.Value End If Next b TotalRng = SumRng End Function وفي الخلية H17 =TotalRng(البيانات!$H$2:$H$80;K1) مع تلوين الخلية K1 باللون الهدف فرز بيانات ذات اللون 2الازرق.xlsm

من الافضل اخي محاولة تصميم يوزرفورم والاشتغال عليه لتتمكن من الاستفادة من عدة مميزات سواءا في البحث او الاظافة او التعديل

تفضل جرب test.xlsm

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

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

تفضل اخي Option Explicit Sub FILTRE() ' فلترة البيانات بين تاريخين واسم القسم Dim i&, R, LastRow As Long, rngCell, c As Range Dim a(1 To 3) a(1) = [BK1]: a(2) = [BK2]: a(3) = [BP1] Dim MyRng As Range Dim WSdata As Worksheet: Set WSdata = ThisWorkbook.Sheets("Sheet1") Application.ScreenUpdating = False WSdata.Range("BJ5:BY1000").ClearContents Set MyRng = WSdata.Range("AM2:BD" & WSdata.Cells(WSdata.Rows.Count, "am").End(xlUp).Row) R = MyRng For i = 1 To UBound(R) If R(i, 17) >= a(1) And R(i, 17) <= a(2) And R(i, 18) = a(3) Then WSdata.Range("BJ" & Rows.Count).End(xlUp).Offset(1).Resize(1, 16).Value _ = Array((R(i, 1)), (R(i, 2)), (R(i, 3)), (R(i, 4)), (R(i, 5)), (R(i, 6)), (R(i, 7)), (R(i, 8)), (R(i, 9)), (R(i, 10)), (R(i, 11)), (R(i, 12)), (R(i, 13)), (R(i, 14)), (R(i, 15)), (R(i, 16))) End If Next ' تسطير البيانات LastRow = WSdata.Range("BJ:BY").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngCell = WSdata.Range("BJ5 :BY" & LastRow) WSdata.Range("BJ5:BY1000").Borders.LineStyle = xlNone For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next If Application.WorksheetFunction.CountA(WSdata.Range("BJ5:BY5")) = 0 Then MsgBox "ليس هناك بيانات مطابقة لمعايير الفلترة الحالية", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه" End If Application.ScreenUpdating = True End Sub اظافات ممكن تفيدك للاشتغال على الملف بشكل افضل Sub CreateValidation() 'انشاء قوائم التاريخ والقسم تلقائيا بدون تكرار Dim J, K, lr As Long Dim a(1 To 2) As String Dim WSdata As Worksheet: Set WSdata = Worksheets("Sheet1") lr = WSdata.Range("BC:BD").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row J = WSdata.Range("BC2:BC" & lr): K = WSdata.Range("BD2:BD" & lr) J = column(Application.Transpose(J)): a(1) = Join(J, ",") K = column(Application.Transpose(K)): a(2) = Join(K, ",") With WSdata.Range("BK1:BK2").Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=a(1) End With With WSdata.Range("BP1").Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=a(2) End With End Sub Function column(arr) As Variant With Application column = .Index(arr, 1, Filter(.IfError(.Match(.Transpose(.Evaluate("ROW(1:" & _ UBound(.Match(arr, arr, 0)) & ")")), .Match(arr, arr, 0), 0), "|"), "|", False)) End With End Function وفي حدث ورقة1 انسخ الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) ' تحديث القوائم عند الاظافة او التعديل في عمود التاريخ او القسم On Error Resume Next lr = Range("BC" & Rows.Count).End(xlUp).Row If Not Intersect(Target, Range("BC2:BC" & lr)) Is Nothing Then Application.EnableEvents = False Call CreateValidation Application.EnableEvents = True Exit Sub End If ' تنفيد الكود عند التغيير في خلية القسم If Not Intersect(Target, Target.Worksheet.Range("BP1")) Is Nothing Then If Target.Cells.Value = " " Or IsEmpty(Target) Then Exit Sub Call FILTRE Application.EnableEvents = True End If On Error GoTo 0 End Sub استخراج بالتاريخ 2.xlsm