محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته لم افهم مادا تقصد بتصفية البيانات في جدول منفصل لاكن على العموم للحصول على النتيجة الظاهرة في الصورة اعلى يكيفي استخدام الكود التالي 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

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

Sub test1() Dim Cpt As Range, Rng As Range Application.ScreenUpdating = False Irows = "12:34" Set Cpt = Range("A12:A" & Cells(Rows.Count, "A").End(xlUp).Row) For Each Rng In Cpt If Rng.Value = "0" Then Rng.EntireRow.Hidden = True Next Rng ActiveWindow.SelectedSheets.PrintOut Copies:=1 Rows(Irows).Hidden = False Application.ScreenUpdating = True End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub test2() Dim i As Long, LastRow As Long Application.ScreenUpdating = False StartRow = 12: LastRow = 34 Rows(StartRow & ":" & LastRow).EntireRow.Hidden = False For i = LastRow To StartRow Step -1 If Cells(i, "A") = "0" Then Rows(i).Hidden = True Next i ActiveSheet.PrintOut Rows(StartRow & ":" & LastRow).EntireRow.Hidden = False Application.ScreenUpdating = True End Sub البرنامج.xlsm في حالة الرغبة بتسلسل عمود (م) على حسب البيانات الموجودة أثناء الطباعة قم بإستبدال المعادلة الخاصة بك بالصيغة التالية مع سحبها للأسفل الخلية (B12) =IF(D12>0;SUBTOTAL(103;$D12:D$12);"")

من المفروض ارفاق الملف في اول مرة بنفس تنسيق الملف الاصلي اخي سعد هناك بعض الاخطاء البسيطة على ملفك تسببت في عدم تنفيد الكود بالشكل الصحيح 1) عدم تطابق الاسماء في رؤوس اعمدة المواد والقائمة المنسدلة 2) لم تقم بتغيير عمود لصق البيانات ليتوافق مع الشكل الجديد ' لصق بعد اخر خلية من عمود (AG) desWS.Cells(Rows.Count, 33).End(xlUp).Offset(1).PasteSpecial xlPasteValues Or desWS.Cells(desWS.Rows.Count, "AG").End(xlUp).Offset(1).PasteSpecial xlPasteValues مع تفريغه في اول الكود بالشكل التالي لكي لا يتم نسخ البيانات تحت بعضها البعض desWS.Range("AG13:AG" & Rows.Count).ClearContents وفي حدث ورقة saad Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Select Case Target.Address(0, 0) Case "Y7": Call CopyData2: Case "AF8": Call CopyData2 Target.Select Case Else: Exit Sub End Select End Sub eman v2.xlsm

Sub TEST1() Dim WordApp As Object, objDoc As Object, Fname As Variant Dim WSdst As Worksheet: Set WSdst = ThisWorkbook.Sheets("word") WSdst.Cells.Clear Fname = Application.GetOpenFilename("Word Documents, *.doc*") If Fname = False Then Exit Sub On Error Resume Next Set WordApp = CreateObject("Word.Application") Set objDoc = WordApp.Documents.Open(Fname) WordApp.Selection.WholeStory WordApp.Selection.Copy WSdst.Range("A1").Select ActiveSheet.Paste With WSdst .Cells.EntireRow.AutoFit: .Columns("A:A").ColumnWidth = 15: '<- قم بتنسيق الورقة بما يناسبك .Columns("A:D").HorizontalAlignment = xlCenter: .Columns("B:E").ColumnWidth = 31 End With objDoc.Close False WordApp.Quit Set WordApp = Nothing Set objDoc = Nothing End Sub في حالة الرغبة باختيار صفحات معينة اليك الكود التالي Sub ImportWordTablesArray() Dim tables() As Variant Dim WordApp As Object, WordDoc As Object Dim arrFile As Variant, Filename As Variant Dim Table As Integer, iCol As Integer Dim iRow As Long, Cpt As Long, Counter As Long Dim WSdst As Worksheet: Set WSdst = ThisWorkbook.Sheets("word") On Error Resume Next arrFile = Application.GetOpenFilename("ملف وورد (*.doc; *.docx),*.doc;*.docx", 2, _ "اظافة الملف", , True) If Not IsArray(arrFile) Then Exit Sub Application.ScreenUpdating = False Set WordApp = CreateObject("Word.Application") WordApp.Visible = False WSdst.Cells.Clear '<- '<-افراغ البيانات السابقة For Each Filename In arrFile Set WordDoc = WordApp.Documents.Open(Filename, ReadOnly:=True) With WordDoc Table = WordDoc.tables.Count If Table = 0 Then MsgBox WordDoc.Name & "لا يحتوي على جداول", vbExclamation, "استيراد" End If tables = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24) '<- '<- ارقام الصفحات For Counter = LBound(tables) To UBound(tables) With .tables(tables(Counter)) For iRow = 1 To .Rows.Count For iCol = 0 To .Columns.Count Cells(Cpt, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text) Next iCol Cpt = Cpt + 1 Next iRow End With Cpt = Cpt + 1 With WSdst .Cells.EntireRow.AutoFit: .Columns("A:b").AutoFit: '<- قم بتنسيق الورقة بما يناسبك .Columns("A:D").HorizontalAlignment = xlCenter: .Columns("c:e").ColumnWidth = 31 End With Next Counter .Close False End With Next Filename WordApp.Quit Set WordDoc = Nothing Set WordApp = Nothing End Sub WORD.rar

Sub Test() Dim lr As Long, r As Range Dim ws As Worksheet: Set ws = Worksheets("واجهة") Dim Wdst As Worksheet: Set Wdst = Worksheets("مبيعات") Const Check = "A13:C13": Set r = ws.Range(Check): Rng = ws.[A3:AA13].Value lr = Wdst.Cells(Rows.Count, 3).End(xlUp).Row + 1 If Application.WorksheetFunction.CountA(r) < r.Count Then MsgBox "برجاء اكمال البيانات", vbExclamation, "كود الترحيل " Exit Sub Else Wdst.Range("A" & lr).Resize(UBound(Rng), UBound(Rng, 2)).Value2 = Rng ws.[A13:AA13] = Empty MsgBox "تم بنجاح", vbInformation, "كود الترحيل " End If End Sub ترحيل1 V1.xlsm

مجهود تشكر عليه استاذ احمد محاولة بطريقة اخرى ربما تتضح الفكرة في انتظار التوضيح اكثر من صاحب الملف =(INDEX('رئيسي '!B:B,MAX(('رئيسي '!$A$2:$A$100="كرتونة صنف "&$A$1)*ROW($A$2:$A$100)*('رئيسي '!$B$2:$B$100<>""))))-(INDEX(B:B,MAX(($C$2:$C$100=$A$1)*ROW($C$2:$C$100)*($B$2:$B$100<>""))))&" "&"علبة" getBalance 6.xlsm