محمد هشام.

ربما لم تنتبه للكود اذا اردت الاشتغال على ورقة 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  

في حدث 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

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

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

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

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

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

ربما لو قمت بارفاق عينة للنتائج المتوقعة اول مرة وبنفس تنسيق ملفك الاصلي  لكنا في غنى عن كل هده المحاولات ووفرت علينا وعلى نفسك الكثير 
 اختيارك لافضل اجابة عند توصلك للحل  في اي مشاركة على المنتدى سوف تكون مرجعا لم يحتاجها من بعدك خاصة عند كثرت التعديلات فلا تغفل عنها 😉
الرجاء  اخي  @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 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

وعليكم السلام ورحمة الله تعالى وبركاته 
Public Sub CopyData() Dim Irow&, Rng&, rowLast&, c&, Cpt As Variant Dim Clé1 As String, Clé2 As String, rngFound As Range, rngSearch As Range Dim Col_Star As Long, Col_Search As Long, i As Long, lRow As Long Dim desWS As Worksheet: Set desWS = ThisWorkbook.Worksheets("saad") Col_Star = 10: Col_Search = 18: Clé1 = desWS.[R12]: Clé2 = desWS.[U12] With Application .EnableEvents = False .ScreenUpdating = False If Len(Clé1) > 0 And Len(Clé2) > 0 Then desWS.Range("C14:U" & Rows.Count).ClearContents Sh = Array("Sheet1", "Sheet2", "Sheet3") For i = LBound(Sh) To UBound(Sh) Set WSData = Sheets(Sh(i)) With WSData .AutoFilterMode = False Irow = .Cells(.Rows.Count, Col_Search).End(xlUp).Row ligne = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngFound = .Range("C9:T" & ligne) End With For Rng = Col_Star To Irow If WSData.Cells(Rng, Col_Search).Value = Clé1 Then rowLast = desWS.Cells(desWS.Rows.Count, 3).End(xlUp).Row Cpt = Array(3, 4, 5, 6, 5, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20) For c = 0 To UBound(Cpt) desWS.Cells(rowLast, Cpt(c)).Offset(1, 0).Value = WSData.Cells(Rng, Cpt(c)).Value Next c End If Next Rng rngFound.AutoFilter Field:=16, Criteria1:=Clé1 Set rngSearch = WSData.Rows(9).Find(Clé2, LookIn:=xlValues, lookat:=xlWhole) If Not rngSearch Is Nothing Then rngSearch.Offset(1).Resize(ligne - 1).Copy desWS.Cells(Rows.Count, 21).End(xlUp).Offset(1).PasteSpecial xlPasteValues rngFound.AutoFilter: desWS.[R12].Select End If Next i End If .EnableEvents = True .ScreenUpdating = True End With End Sub  
ترحيل الدرجات v2.xlsm

تفضل اخي حاولت قدر الامكان اختصار الكود بطريقة ابسط نوعا ما ليسهل التعامل معه والتعديل عليه للضرورة مع توضيح بعض النقاط المهمة 
Sub GetPrice3() Dim WSitems As Worksheet, WSPrice As Worksheet, dest As Worksheet, ws As Worksheet Dim s As Range, Title As Range, r As Range, Rng As Range, ShtDate As Date, MaxDate As Date Dim c As Range, f As Range, a&, XPric As String, Clé As Range Set WSitems = ThisWorkbook.Sheets("items") Set dest = Worksheets("itemout") 'B4 'استخراج اسم قائمة الاسعار بشرط التاريخ المدخل في الخلية XPric = dest.Range("E4"): Set Title = dest.[B8:B32] If Len(dest.Range("B4").Value) = 0 Then: MsgBox "يجب عليك إدخال التاريخ", vbExclamation: Exit Sub If IsDate(dest.Range("B4").Value) Then For Each ws In Worksheets If IsDate(ws.Name) Then ShtDate = CDate(ws.Name) If ShtDate <= dest.Range("B4").Value And ShtDate > MaxDate Then MaxDate = ShtDate End If Next ws If MaxDate = 0 Then MsgBox "قائمة الأسعار " & dest & _ vbCrLf & vbCrLf & "غير موجودة", _ vbInformation, "التحقق من قوائم الأسعار" Else 'تعريف الورقة الهدف Set WSPrice = Sheets(Format(MaxDate, "dd-m-yyyy")) End If End If 'التحقق من ادخال كود الصتف If Application.WorksheetFunction.CountA(dest.Range("B8:B32")) = 0 Then MsgBox "المرجوا ادخال كود الصنف", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "Admin" Exit Sub End If With Application .EnableEvents = False .ScreenUpdating = False If WSPrice.FilterMode Then WSPrice.ShowAllData ' البحث عن عمود نوع التعامل Set Clé = WSPrice.Rows(3).Find(What:=XPric, LookIn:=xlValues, _ LookAt:=xlWhole) If Not Clé Is Nothing Then ' افراغ البيانات السابقة For a = 8 To 32 Union(dest.Range("A" & a), dest.Range("C" & a), dest.Range("G" & a & ":H" & a)).ClearContents Next a '******** ' جلب البيانات من القائمة************* ' بشرط كود الصنف عمود 'B' For Each r In dest.Range("B8", dest.Cells(Rows.Count, 2).End(xlUp)) 'D' البحث في قائمة الاسعار عمود Set Rng = WSPrice.Range("D:D").Find(r.Value, , xlValues, xlWhole) If Not Rng Is Nothing Then '7(G)' وضع السعر في عمود dest.Cells(r.Row, 7).Value = WSPrice.Cells(Rng.Row, Clé.Column).Value ' تحديد عود السعر بشرط الخلية 'E4 For Key = 8 To dest.Range("B" & Rows.Count).End(xlUp).Row 'items'جلب اسم الصنف من ورقة Set Col = WSitems.Cells.Find(What:=dest.Range("B" & Key), LookAt:=xlPart) If Not Col Is Nothing And Col <> "" Then dest.Range("C" & Key) = Col.Offset(0, 1).Value Next Key End If Next ' تسلسل عمود 'A' For Each s In Title If s.Value <> "" Then J = J + 1: s.Offset(0, -1).Value = Format(J, "0") Next fRng = dest.Range("B" & dest.Rows.Count).End(xlUp).Row 'القيمة F*G With dest.Range("H8:H" & fRng) .Formula = "=IF(F8<>"""",F8*G8,"""")" .Value = .Value End With ' نسخ اسم قائمة السعر المستخدمة dest.[i1] = "اسعار قائمة" & ":" & WSPrice.Name Else MsgBox "نوع التعامل غير موجود" & _ vbCrLf & "", vbExclamation, XPric End If .EnableEvents = True .ScreenUpdating = True End With End Sub وكما سبق الذكر سابقا عند نسخك للكود على ملفك الاصلي  تأكد  من تطابق بيانات الخلية E4 مع رؤؤوس الأعمدة في أوراق قوائم الأسعار 
اليك الملف للتجربة
 
price list officena V4.xlsm

اعتقد ان الكود الخاص بي يفعل نفس الشيء ينقصه فقط تحديد النطاق المرغوب الاشتغال عليه لعدم دكرك دالك في اول مشاركة 
يمكنك التحقق من الرابط التالي    :  https://streamable.com/49qe96
تم تعديل الكود ليتناسب مع طلبك الاخير 
Sub Find_and_Replace_values() Dim Title As Variant, WS As Worksheet: Set WS = ActiveSheet Dim arr(2) As Variant, WSrng As Range, i As Integer, Cpt As Long Title = Array("البحث", "الاستبدال") i = 0 Do 'قيمة البحث والاستبدال arr(i) = InputBox(" أدخل قيمة " & " " & Title(i), Title(i)) If StrPtr(arr(i)) = 0 Then Exit Sub If Len(arr(i)) = 0 Then MsgBox "يجب عليك إدخال قيمة" & " " & Title(i), 48, "خطأ" Else i = i + 1 End If Loop Until i > 1 On Error Resume Next ' تحديد النطاق Set WSrng = Application.InputBox(Prompt:=" تحديد نطاق البحث: ", _ Title:="البحث والاستبدال", _ Default:=Selection.Address, Type:=8) If WSrng Is Nothing Then Exit Sub WSrng.Replace arr(0), arr(1), xlPart, , False Cpt = WorksheetFunction.CountIf(WSrng, arr(1)) MsgBox " تم إستبدال " _ & Cpt & " قيمة" _ & vbCrLf & vbCrLf _ & " " & "من" & " " & arr(0) & " " & "إلى" & " " & arr(1), vbInformation, "information" End Sub في حالة الرغبة بعدم استبدال الصيغ بصفة عامة والتعامل مع القيم فقط  يمكنك استخدام هدا الخيار 
''''''''''''''' ' تحديد النطاق Set WSrng = Application.InputBox(Prompt:=" تحديد نطاق البحث: ", _ Title:="البحث والاستبدال", _ Default:=Selection.Address, Type:=8) If WSrng Is Nothing Then Exit Sub For Each c In WSrng If Not c.HasFormula And c <> "" Then c.Replace arr(0), arr(1), xlPart, , False Cpt = WorksheetFunction.CountIf(WSrng, arr(1)) End If Next c MsgBox " تم إستبدال " _ & Cpt & " قيمة" _ & vbCrLf & vbCrLf _ & " " & "من" & " " & arr(0) & " " & "إلى" & " " & arr(1), vbInformation, "information" End Sub  
 
 
Find_and_Replace_FormulaVersion3.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
Sub Copy_Sheet() 'انشاء ورقة جديدة وتسميتها وفق التسلسل المطلوب Dim f As Worksheet, Msg As Variant, Data As Worksheet Dim WSname As String, Cpt As String Set Data = Sheets("T1") WSname = "SMS" & Format(Date, "DDMMYY") Msg = MsgBox("انشاء ورقة جديدة؟", vbYesNo, WSname) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next Cpt = Worksheets(WSname).Name If Cpt = "" Then Data.Copy after:=ActiveWorkbook.Sheets(Worksheets.Count) ' اظافة تاريخ واسم اليوم Set f = ActiveSheet f.Name = WSname: f.[E1].Value = Date: f.[C1].Value = Format(Date, "DDDD") '*******للاحتفاظ بالصيغ يمكنك الغاء هدا السطر With f.ListObjects(1).DataBodyRange .Value = .Value End With '********************************************** Else MsgBox "ورقة العمل موجودة مسيقا" & _ "", vbInformation, WSname End If .ScreenUpdating = True .DisplayAlerts = True End With End Sub  
Sub Save_folder_PDF() 'PDF '<-- حفظ داخل مجلد في نفس مسار الملف الرئيسي Dim WS As Worksheet: Set WS = ActiveWorkbook.Sheets(Worksheets.Count) Dim path As String, folderName As String, Fname As String, Msg As Variant Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير الملف بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next path = ThisWorkbook.path & "\" folderName = "ملفات PDF" MkDir path & folderName Fname = folderName & "\" & WS.Name & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=path & Fname ScreenUpdating = True .DisplayAlerts = True End With MsgBox "تم حفظ الملف بنجاح" & vbLf & vbLf & path & _ "", vbInformation, folderName On Error GoTo 0 End Sub  
Sub Save_folder_Excel() 'Excel '<-- حفظ داخل مجلد في نفس مسار الملف الرئيسي Dim WS As Worksheet: Set WS = ActiveWorkbook.Sheets(Worksheets.Count) Dim path As String, folderName As String, Fname As String path = ThisWorkbook.path & "\" On Error Resume Next Msg = MsgBox("؟" & " " & "Excel " & ":" & " تصدير الملف بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False folderName = "ملفات Excel" MkDir path & folderName Fname = folderName & "\" & WS.Name WS.Copy Application.ActiveWorkbook.SaveAs fileName:=path & Fname & ".xlsx", FileFormat:=51 ActiveWorkbook.Close .DisplayAlerts = True .ScreenUpdating = True End With On Error GoTo 0 MsgBox "تم حفظ الملف بنجاح" & vbLf & vbLf & path & _ "", vbInformation, folderName End Sub مع اظافة امكانية تنفيد الاكواد بطريقة اخرى ستجدها داخل الملف المرفق
 
بالتوفيق...
نمودج V2.xlsb

ربما غير واضح ويلزمه بعض التركيز 🤔😁
تفضل اخي جرب واي استفسار او اظافة لا تتردد في دكرها 
Sub GetPrice() Dim Lastrow&, Dest_Last&, Cpt&, DataRow&, WSDestRow&, i& Dim WSPrice As Worksheet, WSDest As Worksheet, WS As Worksheet Dim Clé As Object, dictKey As String, Price_list As String Dim srcRng As Range, KeyRng As Range, Dest_Rng As Range Dim Col As Variant, f As Variant, Réf As Variant Dim ShtDate As Date, MaxDate As Date With Application .EnableEvents = False .ScreenUpdating = False Set WSDest = Worksheets("itemout"): Price_list = WSDest.[B4].Value If Price_list = vbNullString Then: MsgBox "يجب عليك إدخال التاريخ", vbInformation: Exit Sub If Len(Price_list) > 0 Then If IsDate(WSDest.Range("B4").Value) Then For Each WS In Worksheets If IsDate(WS.Name) Then ShtDate = CDate(WS.Name) If ShtDate <= Price_list And ShtDate > MaxDate Then MaxDate = ShtDate End If Next WS If MaxDate = 0 Then MsgBox "قائمة الأسعار " & Price_list & _ vbCrLf & vbCrLf & "غير موجودة", _ vbInformation, "التحقق من قوائم الأسعار" Else On Error Resume Next Set WSPrice = Sheets(Format(MaxDate, "dd-m-yyyy")) With WSPrice DataRow = 5 Lastrow = .Range("D" & .Rows.Count).End(xlUp).Row Set srcRng = .Range(.Cells(DataRow, "D"), .Cells(Lastrow, "J")) Col = srcRng.Value2 End With With WSDest WSDestRow = 8 Dest_Last = .Range("B" & .Rows.Count).End(xlUp).Row Set KeyRng = .Range(.Cells(WSDestRow, "B"), .Cells(Dest_Last, "F")) f = KeyRng.Value2: Set Dest_Rng = .Cells(WSDestRow, "G") WSDest.[G8:G32] = Empty ReDim Réf(1 To UBound(f, 1), 1 To 1) End With Set Clé = CreateObject("Scripting.dictionary") For i = 1 To UBound(Col) dictKey = Col(i, 1) If Not Clé.exists(dictKey) And (dictKey) <> "" Then Clé(dictKey) = i End If Next i For i = 1 To UBound(f) dictKey = f(i, 1) If Clé.exists(dictKey) Then Cpt = Clé(dictKey) Réf(i, 1) = Col(Cpt, 7) End If Next i Dest_Rng.Resize(UBound(Réf, 1), UBound(Réf, 2)) = Réf End If End If End If .EnableEvents = True .ScreenUpdating = True End With MsgBox "تم جلب الأسعار من قائمة" & " " & WSPrice.Name & " " & "بنجاج", _ vbInformation, "التحقق من قوائم الأسعار" End Sub  
price list officena V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 
Sub test() LastSheet = Sheets.Count Sheets("نمودج").Copy after:=Sheets(LastSheet) End Sub  نسخ و اعادة التسمية 
Sub test2() Dim F As Variant LastSheet = Sheets.Count On Error Resume Next Sheets("نمودج").Copy after:=Sheets(LastSheet) F = InputBox(prompt:="أكتب إسم الورقة الجديد", _ Title:="إعادة تسمية ورقة " & " " & ActiveSheet.Name) ActiveSheet.Name = F End Sub 'قم بتعديله بما يناسبك Sub test3() LastSheet = Sheets.Count On Error Resume Next Sheets("نمودج").Copy after:=Sheets(LastSheet) ActiveSheet.Name = Sheets("TEST").Range("c4").Value End Sub  
نمودج.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
بعد ادن الاستاد المحترم @محمد حسن المحمد 
تفضل جرب اخي 
Sub Total_amount() Dim WS As Worksheet, Dest As Worksheet: Set WS = Sheets("Sheet1"): Set Dest = Sheets("التجميع بدون تكرار") a = WS.Range("B1").CurrentRegion.Value Dim c() ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2)) Cpt = 1 Set mondico = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False For i = 1 To UBound(a) temp = a(i, 1) & a(i, 2) If Not mondico.exists(temp) Then mondico.Add temp, "" For k = 1 To UBound(a, 2) - 1: c(Cpt, k) = a(i, k): Next k c(Cpt, k) = c(Cpt, k) + a(i, k) Cpt = Cpt + 1 Else j = Application.Match(temp, mondico.keys, 0) col = UBound(a, 2) c(j, col) = c(j, col) + a(i, col) End If Dest.[B1:D1000] = Empty Next Dest.[B1].Resize(mondico.Count, UBound(a, 2)) = c End Sub  
كود تجميع .xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
تفضل جرب الصيغة التالية 
=IFERROR(IF(B8<>"";INDEX(price_list!$J$5:$J$10000;MATCH(2;1/(price_list!$E$5:$E$10000=B8)/(price_list!$A$5:$A$10000<=$B$4)));"");"")  اخر سعر
=INDEX(price_list!$J$5:$J$10000;MATCH(2;1/(price_list!$E$5:$E$10000=B8))) اكبر سعر
=MAX(IF(price_list!$A$5:$A$10000<=$B$4;IF(price_list!$E$5:$E$10000=B8;price_list!$J$5:$J$10000)))  
price list officena - 2.xlsm

قم باستبدال 
If TblInv(i, 1) = CB_Pièce Then الى 
If TblInv(i, 1) = CB_Pièce.Text Then  

اخي ربما يتعين عليك وضع حماية لورقة العمل لديك لمنع اظهار الاعمدة او اخفائها بدون ادخال كلمة المرور  
جرب هدا الملف باسوورد  1234
 
 
إخفاء اعمدة وصفوف برقم سري.xlsb

بما انك لم تقم بارفاق الملف لنتمكن من تحديد النطاق المرغوب نسخه اليك مثال للمطلوب يمكنك تعديله بما يناسبك 
Sub Copy_My_Data() Dim Cpt&, lCol&, lRow& Dim WSdata As Worksheet, Dest As Worksheet, MyRng As Range, r As String Dim WS1 As Workbook, WS2 As Workbook :Set WS1 = ThisWorkbook With Application .ScreenUpdating = False r = InputBox("قم بإدخال اسم المصنف المرغوب جلب البيانات منه", "Choose file name") On Error Resume Next If r = False And r <> 0 Then Exit Sub If r = 0 Then Set WS2 = Workbooks("transactionTable.xls") 'اول نسخة من المصنف = 0 Else Set WS2 = Workbooks("transactionTable" & " (" & r & ")" & ".xls") ' تعريف المصنف من خلال الرقم End If If Not WS2 Is Nothing Then Set WSdata = WS2.Sheets("Sheet1") ' transactionTable اسم الشيت المنسوخ منه lRow = WSdata.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lCol = WSdata.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column ' قم بتعديل النطاق المنسوخ بما يناسبك Set MyRng = WSdata. _ Range("A2", WSdata.Cells(lRow, lCol)) Set Dest = WS1.Sheets("Sheet1") ' b2024' اسم شيت اللصق على ملف Cpt = Dest.Cells(Dest.Rows.Count, "A").End(xlUp).Offset(1).Row MyRng.Copy Dest.Range("A" & Cpt).PasteSpecial Paste:=xlPasteValues Application.Goto Dest.[A1], True .CutCopyMode = False .ScreenUpdating = True MsgBox _ "تم نسخ البيانات بنجاح من" & Chr(10) & Chr(10) & WS2.Name, vbInformation Else MsgBox (" لم يتم العثور على المصنف ") & r, 48, "خطأ" On Error GoTo 0 End If End With End Sub  بالتوفيق......
 
 
test 2.rar

وعليكم السلام ورحمة الله تعالى وبركاته  
ربما هدا ما تقصد 
Sub test() Dim i As Long, lRow As Long lRow = Cells(Rows.Count, "A").End(xlUp).Row With Application .ScreenUpdating = False For i = lRow To 2 Step -1 If IsError(.Match(0, Range("A" & i & ":D" & i), 0)) Then Rows(i).EntireRow.Delete End If Next .ScreenUpdating = True End With End Sub  
ملف.xlsb

مع بعض التعديلات البسيطة 
Sub Find_And_copy() ' to Update 06 / 01 / 2024 Dim c As Range: Dim Col As Range Dim r As Range: Dim Rng As Range Dim WS As String: Dim j As Long Dim lastrow As Long: Dim MyData As Worksheet: Set MyData = Feuil2 On Error Resume Next If MyData.[H2] = "" Then: MsgBox "المرجوا إدخال تاريخ الغياب", vbInformation, "admin": Exit Sub lastrow = MyData.Columns("G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row If WorksheetFunction.CountA(MyData.Range("G4:G" & lastrow + 1)) = 0 Then MsgBox "يرجى ملئ بيانات" & " : " & [G3], vbExclamation: Exit Sub If WorksheetFunction.CountA(MyData.Range("H4:H" & lastrow + 1)) = 0 Then MsgBox "يرجى ملئ بيانات" & " : " & [H3], vbExclamation: Exit Sub For j = 4 To lastrow If MyData.Range("G" & j) <> "" Then: WS = MyData.Cells(j, "G") Set MyDest = Worksheets(WS) With Application .ScreenUpdating = False With MyDest For Each r In MyDest.Range("A5", .Cells(Rows.Count, 1).End(xlUp)) Set Rng = MyData.Range("A:A").Find(r.Value, , xlValues, xlWhole) If Not Rng Is Nothing Then For Each c In Application.Intersect(MyData.UsedRange, MyData.[H2]) If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then Set Col = MyDest.Rows(3).Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole) If Col Is Nothing Then: MsgBox "المرجوا التحقق من تاريخ الإدخال" & " : " & MyData.[H2].Value, vbInformation, "تعليمات": Exit Sub If Not Col Is Nothing And Rng.Offset(, 6).Value = MyDest.Name Then MyDest.Cells(r.Row, Col.Column).Value = Rng.Offset(, 7).Value End If End If Next c End If Next End With .ScreenUpdating = True End With Next j On Error GoTo 0 MyData.Range("G4:H" & lastrow + 1).ClearContents: [H2] = Empty MsgBox "تم ترحيل البيانات بنجاح ", vbInformation, "admin" End Sub  
 
ترحيل بيانات 6.xlsm

Copy of مسلسل فاتورة على حسب نوع الفاتورة.xlsm

اخي قم بازاحة العمود الاول على ورقة الشيكات للحصول على عمود A  فارغ ووضع المعادلة التالية  مع سحبها الى الاسفل على حسب البيانات الموجودة لديك 
 
=IF(G2<>"";COUNTIF($G$2:G2;G2)&"-"&G2;"") وفي ورقة اليومية الخلية  Q8 ضع المعادلة الاتية مع سحبها الى الاسفل 
=IFERROR(VLOOKUP(COUNTIF($A$8:A8;A8)&"-"&A8;الشيكات!$A$2:$G$1000;2;0);"")  اليك الملف للتجربة 
 
استخراج رقم من البيانV2.xlsx

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

واستخدام الكود التالي 
Sub Spinner2_Change() Dim myRange As Range, cell As Range 'نطاق البيانات Set myRange = Range("F5:F33") With Application .ScreenUpdating = False On Error Resume Next With myRange .Interior.ColorIndex = xlColorIndexNone: .Font.Color = RGB(0, 0, 0) End With For Each cell In myRange If Not IsError(.Match(cell.Value, Columns("AG"), 0)) Then ' عمود اسماء الالوان ' لون الخلفية cell.Interior.Color = Cells(.Match(cell.Value, Columns("AG"), 0), "AH").Interior.Color ' عمود الالوان ' لون الخط cell.Font.Color = Cells(.Match(cell.Value, Columns("AG"), 0), "AH").Interior.Color End If Next .ScreenUpdating = True End With On Error GoTo 0 End Sub  
تلوين 3.xlsm