محمد هشام.

اظن ان دالك بسبب طريقة تصميمك للملف حاول فلترة بياناتك يدويا ستجد نفس التداخل في العناصر المدكورة

في حدث Private Sub Worksheet_Activate ضع الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) Dim a, i&, k&, b$, S$, lRow& Dim WS As Worksheet: Set WS = Sheets("البيانات") Dim desWS As Worksheet: Set desWS = Sheets("البحث") b = desWS.[E2] On Error Resume Next Application.ScreenUpdating = False If Not Intersect(Target, Target.Worksheet.Range("E2")) Is Nothing Then If Target.Cells.Value = "" Or IsEmpty(Target) Then Exit Sub desWS.Range("A5:j" & Rows.Count).ClearContents a = WS.Range("A3:J" & WS.[a65000].End(xlUp).Row) For i = 1 To UBound(a) If a(i, 4) = b Or a(i, 7) = b Or a(i, 10) = b Then desWS.Cells(k + 5, 1).Resize(, 10) = Application.IfError(Application.Index(a, i, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)), "") k = k + 1 ActiveWindow.DisplayZeros = False End If Next lRow = desWS.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set Rng = desWS.Range("A5 :J" & lRow) desWS.Range("A5:J500").Borders.LineStyle = xlNone For Each c In Rng.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next Application.ScreenUpdating = True End If End Sub السيارات 24.xlsb

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

يسعدنا اننا استطعنا مساعدتك 😁 بالنسبة للماكرو يمكنك حدفه لا علاقة له بالمطلوب

ربما لم تنتبه للكود اذا اردت الاشتغال على ورقة 2 قم بتعديل هذا السطر لان البيانات يتم جلبها من ورقة 1 Set WS = Worksheets("Sheet1"): Set desWS = Worksheets("Sheet2") الى Set WS = Worksheets("Sheet2"): Set desWS = Worksheets("Sheet2") او تعديله بالكامل بالشكل التالي Option Explicit Public Sub TransposeData2() Dim desWS As Worksheet, rng As Variant Dim Cpt() As Variant, I As Long, J As Long, k As Long, loc As String Set desWS = Worksheets("Sheet2") Application.ScreenUpdating = False rng = desWS.[C6:O10].Value2 For I = 2 To UBound(rng) For J = 2 To UBound(rng, 2) Step 2 If rng(I, J) > 0 Then ReDim Preserve Cpt(2, k + 1) Cpt(0, k) = rng(I, 1) Cpt(1, k) = rng(I, J) k = k + 1 End If Next J Next I If k > 0 Then desWS.Range("C15:D" & Rows.Count).ClearContents desWS.Cells(15, 3).Resize(k, 2).Value = Application.Transpose(Cpt) 'اظافة الجدول loc = desWS.Range("C14:D" & desWS.[D65000].End(xlUp).Row).Address If desWS.ListObjects.Count <> 0 Then Exit Sub desWS.Cells(14, 3).Resize(, 2).Value = Array("Part", "INDEX") desWS.ListObjects.Add(xlSrcRange, desWS.Range(loc), , xlYes).Name = _ "Table1" End If Application.ScreenUpdating = True End Sub

ما فهمت منك لحد الساعة هو انك تريد فلترة ونسخ الصفوف مع الارتباط من ورقة Data الى الورقة النشطة تلقائيا بشرط وجود اسم الورقة في الخلية G2 ادا كان هدا هو طلبك ضع اولا الصيغة التالية في الخلية G2 على جميع الاوراق المرغوب نسخ البيانات عليها للتاكد من مطابقة الاسم يمكنك حدفها بعد دالك =MID(@CELL("filename";A1);FIND("]";@CELL("filename";A1))+1;31) وفي حدث Private Sub Worksheet_Activate ضع الكود التالي Private Sub Worksheet_Activate() Dim lRow2 As Long Set WS = Sheets("data"): Set dest = ActiveSheet If WS.AutoFilterMode Then WS.AutoFilterMode = False lRow2 = WS.Range("A" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False On Error Resume Next If dest.[G2].Value = dest.Name Then With WS.Range("A2:E" & lRow2) .AutoFilter Field:=5, Criteria1:=dest.[G2].Value Set Rng = WS.Range("A2:E" & lRow2).SpecialCells(xlCellTypeVisible) If Rng.Cells.Count > 1 Then With dest.Range("A2:F" & Rows.Count) .ClearContents: .Interior.ColorIndex = 0: .Borders.LineStyle = xlNone End With Rng.Copy dest.Range("A1") End If .AutoFilter End With End If On Error GoTo 0 End Sub TEST V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته لم افهم مادا تقصد بتصفية البيانات في جدول منفصل لاكن على العموم للحصول على النتيجة الظاهرة في الصورة اعلى يكيفي استخدام الكود التالي Option Explicit Public Sub TransposeData() Dim Cpt() As Variant, I As Long, J As Long, k As Long, rng As Variant Dim WS As Worksheet: Set WS = Worksheets("Sheet1") Application.ScreenUpdating = False rng = WS.[C6:O10].Value2 For I = 2 To UBound(rng) For J = 2 To UBound(rng, 2) Step 2 If rng(I, J) > 0 Then ReDim Preserve Cpt(2, k + 1) Cpt(0, k) = rng(I, 1) Cpt(1, k) = rng(I, J) k = k + 1 End If Next J Next I If k > 0 Then WS.Range("C15:D" & Rows.Count).ClearContents WS.Cells(15, 3).Resize(k, 2).Value = Application.Transpose(Cpt) End If Application.ScreenUpdating = True End Sub ولوضعها في جدول يمكنك التعديل على الكود على الشكل التالي هدا مثال لنسخ البيانات على ورقة 2 Option Explicit Public Sub TransposeData2() Dim WS As Worksheet, desWS As Worksheet, rng As Variant Dim Cpt() As Variant, I As Long, J As Long, k As Long, loc As String Set WS = Worksheets("Sheet1"): Set desWS = Worksheets("Sheet2") Application.ScreenUpdating = False rng = WS.[C6:O10].Value2 For I = 2 To UBound(rng) For J = 2 To UBound(rng, 2) Step 2 If rng(I, J) > 0 Then ReDim Preserve Cpt(2, k + 1) Cpt(0, k) = rng(I, 1) Cpt(1, k) = rng(I, J) k = k + 1 End If Next J Next I If k > 0 Then desWS.Range("C15:D" & Rows.Count).ClearContents desWS.Cells(15, 3).Resize(k, 2).Value = Application.Transpose(Cpt) 'اظافة الجدول loc = desWS.Range("C14:D" & desWS.[D65000].End(xlUp).Row).Address If desWS.ListObjects.Count <> 0 Then Exit Sub desWS.Cells(14, 3).Resize(, 2).Value = Array("Part", "INDEX") desWS.ListObjects.Add(xlSrcRange, desWS.Range(loc), , xlYes).Name = _ "Table1" End If Application.ScreenUpdating = True End Sub تصفية تلقائية V2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب الحلول التالية ربما هدا ما تقصده Sub test1() Dim crit$, crit2$, F() As String Dim rng As Range, lr As Long Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim desWS As Worksheet: Set desWS = Sheets("Sheet2") ReDim F(1 To 4) 'Bill Type Code ******************************************Action Type & Terminal Type F(1) = "240": F(2) = "2400": F(3) = "26408": F(4) = "293": crit = "DEB": crit2 = "INT" Application.ScreenUpdating = False If WS.AutoFilterMode Then WS.AutoFilterMode = False With WS.Range("A2:K2") .AutoFilter 3, F, xlFilterValues: .AutoFilter 4, crit, xlFilterValues: .AutoFilter 11, crit2, xlFilterValues lr = WS.Columns("A:A").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set rng = WS.Range("A3:K" & lr).SpecialCells(xlCellTypeVisible) If rng.Cells.Count > 1 Then desWS.Range("A2:F" & Rows.Count).Clear With rng Cpt = Split("A,B,D,J,G,K", ",") ' الاعمدة المرحلة Col = Split("A,B,C,D,E,F", ",") 'الاعمدة المرحل اليها For i = LBound(Cpt) To UBound(Cpt) WS.Range(Cpt(i) & "2:" & Cpt(i) & lr).Copy desWS.Range(Col(i) & "1") Next i End With End If .AutoFilter Application.ScreenUpdating = True End With End Sub ''''''''''''''''''''''''''''''''''''''' Sub test2() Dim a, i&, k&, F$, S$: F = "DEB": S = "INT" Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim desWS As Worksheet: Set desWS = Sheets("Sheet2") Application.ScreenUpdating = False desWS.Range("A2:F" & Rows.Count).Clear a = WS.Range("A2:K" & WS.[A65000].End(xlUp).Row) For i = 1 To UBound(a) 'Action Type & Terminal Type If a(i, 4) = F And a(i, 11) = S Then ''Bill Type Code If a(i, 3) = "240" Or a(i, 3) = "2400" Or a(i, 3) = "26408" Or a(i, 3) = "293" Then ' الاعمدة المرحلة desWS.Cells(k + 2, 1).Resize(, 6) = Application.IfError(Application.Index(a, i, Array(1, 2, 4, 10, 7, 11)), "") k = k + 1 End If End If Next Application.ScreenUpdating = True End Sub ملف عمليات V1.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا الحل هل يناسبك تم وضع كود لجلب البيانات وكود اخر لترحيلها للمكان المناسب على حسب ما فهمت من طلبك Sub Fetch_data() Dim clé As String, SH As String Set desWS = Sheets("رصد درجات") SH = desWS.Range("D1").Value Set f = ThisWorkbook.Sheets(SH) Application.ScreenUpdating = False Tbl = f.Range("C11:R" & f.[c65000].End(xlUp).Row).Value clé = desWS.Range("d3"): colClé = 2 b = arr(Tbl, clé, colClé) If Not IsEmpty(b) Then desWS.Range("C11:R" & Rows.Count).ClearContents desWS.[c11].Resize(UBound(b), UBound(b, 2)) = b Application.ScreenUpdating = True MsgBox "نتائج" & " " & f.Name Else MsgBox "لايوجد نتائج للشرط المعطى" End If End Sub Function arr(Tbl, clé, colClé, Optional Cpt) Dim r() Ncol = UBound(Tbl, 2) If IsMissing(Cpt) Then ReDim r(0 To Ncol - 1): For k = 0 To Ncol - 1: r(k) = k + 1: Next k Else r = Cpt End If Nr = UBound(r) n = 0 For i = LBound(Tbl) To UBound(Tbl) If clé = Tbl(i, colClé) Or clé = "" Then n = n + 1 Next i If n > 0 Then Dim b(): ReDim b(1 To n, 1 To UBound(r) + 1) n = 0 For i = LBound(Tbl) To UBound(Tbl) If clé = Tbl(i, colClé) Or clé = "" Then n = n + 1 For k = 0 To Nr: b(n, k + 1) = Tbl(i, r(k)): Next k End If Next i arr = b End If End Function بيانات التلاميذ 3.xlsm

Sub test() Dim Sh As Worksheet: Dim WS As Worksheet: Set WS = Worksheets("data") Dim I&, F As Range For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> WS.Name Then Application.ScreenUpdating = False For I = 3 To WS.Range("E" & Rows.Count).End(xlUp).Row If WS.Cells(I, "E") = Sh.Name Then WS.Range("A2:E2").Copy Destination:=Sh.Range("A1") Set F = WS.Range(WS.Cells(I, 1), WS.Cells(I, 5)) F.Copy Destination:=Sh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) With Sh.Range("A2:E" & Sh.Range("A" & Rows.Count).End(xlUp).Row) .Interior.Color = xlNone: .EntireColumn.AutoFit End With End If Next I End If Next Sh Application.ScreenUpdating = True End Sub

Test after 2 days تجربة v2.xlsm

Sub tarheel() Dim ws As Worksheet, xx As Integer, lr As Integer, r As Integer Dim sh As Worksheet: Set sh = Sheets(1) For Each ws In ThisWorkbook.Worksheets xx = sh.Cells(32, 3).End(xlUp).Row Application.ScreenUpdating = False For r = 8 To xx If sh.Cells(r, 3).Value = ws.Name And sh.Cells(r, 3).Value <> Empty Then sh.Range(Cells(r, 3), sh.Cells(r, 5)).Copy ws.Range("a" & Rows.Count).End(xlUp).Offset(1, 0).Value = Date ws.Range("b" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues End If Next Next Application.CutCopyMode = False sh.Range("b8:e21").ClearContents Application.ScreenUpdating = True End Sub 'OR**************************** Sub test() Dim Sh As Worksheet Dim WS As Worksheet: Set WS = Sheets(1) Dim iRow As Long, Rng As Range For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> WS.Name Then Application.ScreenUpdating = False For iRow = 8 To 32 If WS.Cells(iRow, "C") Like Sh.Name Then Set Rng = WS.Range(WS.Cells(iRow, 3), WS.Cells(iRow, 5)) Sh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = Date Sh.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(, 3).Value = Rng.Value WS.Range("B8:E21").ClearContents End If Next iRow End If Next Sh End Sub _نموذج جرد السيارات __مع الطباعة - نسخة للتعديل.xlsm

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

التعديل الدي يمكنني اظافته بعد معاينة الملف هو اختصار كود استدعاء الاحتياطي على النحو التالي Sub Compare() Dim lr As Long, i As Long, j As Long Dim strCol As String Dim WS As Worksheet: Set WS = Worksheets("Sheet1") Application.ScreenUpdating = False lr = WS.Columns("A:R").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row 'Columns C to R For i = 3 To 18 strCol = Split((WS.Columns(i).Address(, 0)), ":")(0) For j = 5 To lr If WorksheetFunction.CountIf(WS.Range(strCol & "5:" & strCol & lr), WS.Range("A" & j)) = 0 Then WS.Cells(Rows.Count, strCol).End(xlUp).Offset(1).Value = WS.Range("A" & j).Value End If Next j Next i Application.ScreenUpdating = True End Sub بالتوفيق...........

ربما لو قمت بارفاق عينة للنتائج المتوقعة اول مرة وبنفس تنسيق ملفك الاصلي لكنا في غنى عن كل هده المحاولات ووفرت علينا وعلى نفسك الكثير اختيارك لافضل اجابة عند توصلك للحل في اي مشاركة على المنتدى سوف تكون مرجعا لم يحتاجها من بعدك خاصة عند كثرت التعديلات فلا تغفل عنها 😉 الرجاء اخي @2saad أخذ هده الملاحظات بعين الاعتبار في المشاركات المقبلة. Option Explicit Sub test() Dim lr As Long, i As Long, j As Long Dim strCol As String Dim WS As Worksheet: Set WS = Worksheets("Sheet1") Application.ScreenUpdating = False lr = WS.Columns("A:R").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row 'الاعمدة من C الى F For i = 2 To 6 strCol = Split((WS.Columns(i).Address(, 0)), ":")(0) For j = 1 To lr If WorksheetFunction.CountIf(WS.Range(strCol & "1:" & strCol & lr), WS.Range("A" & j)) = 0 Then WS.Cells(Rows.Count, strCol).End(xlUp).Offset(1).Value = WS.Range("A" & j).Value End If Next j Next i Application.ScreenUpdating = True End Sub

قم بتعديلها بما يناسبك Sub TEST() Dim i As Integer For i = 1 To 100 Step 50 Cells(i, 1).Value = "الصدق" Next i End Sub '''''''''''''''''''''' Sub test2() Dim X As Integer star = 1 ' اول خلية fin = 500 'اخر خلية For X = star To fin Step 50 Range("A" & X).Value = "الصدق" Next X End Sub

marem v4.xlsb

الكود الخاص بك بعد التعديل Sub tarheel() Application.ScreenUpdating = False Dim ws As Worksheet, xx As Integer, ir As Integer xx = Sheet1.Cells(32, 3).End(xlUp).Row For Each ws In ThisWorkbook.Worksheets If ws.Name <> Sheet1.Name Then For r = 8 To xx If Cells(r, 3).Value = ws.Name And Cells(r, 3).Value <> Empty Then Range(Cells(r, 3), Cells(r, 5)).Copy lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 ws.Range("a" & lr).Value = Date ws.Range("b" & lr).PasteSpecial (xlPasteValues) End If Next End If Next Application.CutCopyMode = False Sheet1.Activate Sheet1.Range("b8:e21").ClearContents Application.ScreenUpdating = True End Sub بما انك تريد نسخ البيانات كقيم اليك حل اخر Sub test() Dim Sh As Worksheet Dim WS As Worksheet: Set WS = Worksheets("Sheet1") Dim iRow As Long, Rng As Range For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> WS.Name Then Application.ScreenUpdating = False For iRow = 8 To 32 'WS.Range("C" & Rows.Count).End(xlUp).Row If WS.Cells(iRow, "C") Like Sh.CodeName Then Set Rng = WS.Range(WS.Cells(iRow, 3), WS.Cells(iRow, 5)) Sh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = Date Sh.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(, 3).Value = Rng.Value 'WS.Range("B8:E21").ClearContents End If Next iRow End If Next Sh End Sub TEST SH.xlsm

بالعكس اظن انه يفعل دالك ممكن ترفع صورة للخطا الدي يواجهك او ارفاق عينة للنتائج المتوقعة للتوضيح اكثر https://streamable.com/vememx

تفضل جرب هدا Option Explicit Private Sub Workbook_Open() Call IncrementDailyOpenCounter(UpdateCell:=Sheet1.[a1]) End Sub Private Sub IncrementDailyOpenCounter(ByVal UpdateCell As Range) On Error Resume Next Debug.Assert [DateStamp] If Err Then Call Me.Names.Add("DateStamp", Date, False) GoTo Update End If If Date > [DateStamp] Then Me.Names("DateStamp").Value = CLng(Date) GoTo Update End If Exit Sub Update: UpdateCell = UpdateCell + 1& Me.Save End Sub تجربة v2.xlsm

يمكنك فعلها من خلال 'مثال Private Sub Workbook_Open() Sheet1.[A1] = Sheet1.[A1] + 1 End Sub ''''''''''''''' Or Private Sub Workbook_Open() Dim r As Range Set r = Sheet1.[A1] If r > 0 Then r = r + 1 End Sub لاكن مادا لم قمت بفتح الملف اكثر من مرة في نفس اليوم

https://streamable.com/ktq9k9

ليس لي علم عن المعادلات التي تستخدمها لاكن لا اظن انها لديها اي علاقة بالموضوع قد تمت الاجابة عن طلبك وهو اخفاء الصفوف الصفرية اما مسالة المعادلة مجرد تخمين مني لا غير 😁 مع العلم انها تنفد المطلوب قد لاحظت انك لم تقم بوضع المعادلة بالشكل الصحيح جرب المرفق التالي ووافينا بالنتيجة قد تم الغاء امر الطباعة مؤقتا داخل الكود ووضع ActiveSheet.PrintPreview يمكنك تعديله بعد التجربة البرنامج v2.xlsm

جرب هدا Sub Uniques() 'Col_C_D_E_F Dim Rng As Range, lr& Dim ws As Worksheet: Set ws = Worksheets("Sheet1") lr = ws.Columns("A:F").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For Each Rng In Range("A1:A" & lr) If WorksheetFunction.CountIf(Range("C1:F" & lr), Rng) = 0 Then Range("C" & Rows.Count).End(xlUp).Offset(1) = Rng End If Next End Sub marem v3.xlsb

ادن جرب هدا ووافينا بالنتيجة Sub Compare_Col() Dim lr As Long, i As Long Dim WS As Worksheet: Set WS = Worksheets("Sheet1") On Error Resume Next lr = WS.Columns("A:C").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For i = 1 To lr Application.ScreenUpdating = False If WorksheetFunction.CountIf(Range("C1:C" & lr), Range("A" & i)) < 1 Then Cells(Rows.Count, 3).End(xlUp).Offset(1).Value = Range("A" & i).Value End If Next i Application.ScreenUpdating = True End Sub marem v2.xlsb