محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته 
جرب هدا 
Option Explicit Sub Transfer() Dim srcRange As Range, Lr As Long, destCols As Variant Dim WS As Worksheet, dest As Worksheet, i As Integer Dim a(1 To 1, 1 To 7) As Variant Set WS = ActiveSheet Set dest = Sheets("كشف الحساب") a(1, 1) = WS.[B6].Value: a(1, 2) = WS.[C6].Value: a(1, 3) = WS.[D6].Value a(1, 4) = WS.[E6].Value: a(1, 5) = WS.[G6].Value: a(1, 6) = WS.[H6].Value: a(1, 7) = WS.[I6].Value destCols = Array("C", "D", "E", "F", "H", "I", "J") Lr = dest.Cells(dest.Rows.Count, "D").End(xlUp).Row + 1 For i = 0 To 6 dest.Cells(Lr, destCols(i)).Value = a(1, i + 1) Next i End Sub """""""""""""""""""""""""""""""""""""""""""""""""""""""""" Sub testCopy() Dim i As Integer, ScrWS As Worksheet, btn As Object Dim Sh As Worksheet: Set Sh = Sheets("البون") Application.ScreenUpdating = False Application.DisplayAlerts = False Application.CutCopyMode = False For i = 1 To 15 On Error Resume Next Set ScrWS = ThisWorkbook.Sheets(Sh.Name & i) If Not ScrWS Is Nothing Then ScrWS.Delete Next i For i = 1 To 15 Sh.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) Set ScrWS = ActiveSheet ScrWS.Name = Sh.Name & i ScrWS.DisplayRightToLeft = True For Each btn In ScrWS.Buttons: btn.Delete: Next btn On Error GoTo 0 Set btn = ScrWS.Buttons.Add(400, 20, 60, 30): btn.OnAction = "Transfer": btn.Caption = "ترحيل" Next i Sh.Activate Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub  
الايرادات والمصروفات.xlsm

أخي @Hussein888   في Excel 365 يوجد خاصية تلقائية تعرف بـ AutoComplete التي تجعل القوائم المنسدلة تتفاعل بشكل ديناميكي مع الحروف التي تكتبها في الخلية
 حيث يتم تحديث القائمة لتظهر القيم التي تطابق ما كتبته لكن في Excel 2016 لا توجد هذه الخاصية بشكل افتراضي في القوائم المنسدلة المعتمدة على  Data Validation ولكن هناك حل بديل باستخدام VBA  كما في المثال التالي 

بما أنك لم تقم بإرفاق ملفك لتحديد النطاقات المطلوبة إليك الكود يمكنك تعديله بما يناسبك 
Option Compare Text Dim a() Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' تحديد نطاق القوائم المنسدلة If Not Intersect([A2:A10], Target) Is Nothing And Target.Count = 1 Then ' (الأسماء) تحديد نطاق البيانات Set Rng = Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row) Set tbl = CreateObject("Scripting.Dictionary") tbl.CompareMode = vbTextCompare For Each c In Rng If c.Value <> "" Then tbl(c.Value) = "" Next c a = tbl.Keys 'ترتيب ابجدي tri a, 1, UBound(a) With Me.ComboBox1 .List = a: .Top = Target.Top: .Left = Target.Left: .Width = Target.Width .Height = Target.Height + 3: .Visible = True: .Activate End With Else Me.ComboBox1.Visible = False End If End Sub Private Sub ComboBox1_Change() If Me.ComboBox1.Text <> "" Then Set tbl = CreateObject("Scripting.Dictionary") tmp = "*" & UCase(Me.ComboBox1.Text) & "*" ' البحث عن النص في أي مكان For Each c In a If UCase(c) Like tmp Then tbl(c) = "" Next c Me.ComboBox1.List = tbl.Keys Me.ComboBox1.DropDown End If ActiveCell.Value = Me.ComboBox1.Text End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Me.ComboBox1.List = a Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then ActiveCell.Offset(1).Select End Sub Sub tri(a, gauc, droi) ref = a((gauc + droi) \ 2) g = gauc: d = droi Do Do While a(g) < ref: g = g + 1: Loop Do While ref < a(d): d = d - 1: Loop If g <= d Then temp = a(g): a(g) = a(d): a(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call tri(a, g, droi) If gauc < d Then Call tri(a, gauc, d) End Sub  
Test-Data Validation.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
جرب هدا 
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim n As Range, f As String, count As Integer, i As Integer If Not Intersect(Target, Me.Range("A1:B2")) Is Nothing Then Dim WS As Worksheet: Set WS = Sheets("data") Dim xRow As Range: Set xRow = WS.Range("A1:J1") Dim tmp As Integer: tmp = xRow.Column xRow.ClearContents For Each n In Me.Range("A1:A2") If n.Value <> "" Then f = n.Value count = n.Offset(0, 1).Value For i = 1 To count If tmp > xRow.Columns.count + xRow.Column - 1 Then Exit Sub WS.Cells(xRow.Row, tmp).Value = f tmp = tmp + 1 Next i End If Next n End If End Sub  
 
test2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته
كما سبق الدكر من الأستاد @عبدالله بشير عبدالله   طلبك غير واضح إظافة أن أرقام الأعمدة على الملف تتواجد في الصف 3 ليس 2 
مجرد تخمين ربما تقصد جلب بيانات العمود بشرط إدخال  قيمة رؤوس الأعمدة (رقم العمود)

جرب هدا 
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim OnRng As Variant, tmp As Variant, lastRow As Long, a As Long, Clé As String Dim WS As Worksheet: Set WS = Sheets("Sheet1") If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, WS.Range("AQ3:BO3")) Is Nothing Then lastRow = WS.Columns("A:Z").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row OnRng = WS.Range("A4:Z" & lastRow).Value tmp = WS.Range("A3:Z3").Value Clé = Target.Value Application.ScreenUpdating = False If IsEmpty(Target.Value) Then WS.Range(WS.Cells(4, Target.Column), WS.Cells(lastRow, Target.Column)).ClearContents Else For a = 1 To UBound(tmp, 2) If tmp(1, a) = Clé Then With WS.Range(WS.Cells(4, Target.Column), WS.Cells(lastRow, Target.Column)) .ClearContents .Value = Application.Index(OnRng, 0, a) End With Exit For End If Next a End If If a > UBound(tmp, 2) Then Target.ClearContents: MsgBox "لم يتم العثور على " & _ Target.Value & " في قاعدة البيانات", vbExclamation, "إنتبـــاه" End If Application.ScreenUpdating = True End Sub  
استخراج الاعمدة.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته
ادا كان هدا  ما تقصده 
 
جرب هدا
=IFERROR(TEXT(DATE(2000+LEFT(B2,2),MID(B2,3,2),RIGHT(B2,2)),"DD/MM/YYYY"),"")  او 
Option Explicit Sub ConvertDate() Dim lr As Long, r As Long, xDate As String, n As String Dim scWS As Worksheet: Set scWS = Sheets("Sheet1") lr = scWS.Cells(scWS.Rows.Count, "B").End(xlUp).Row For r = 2 To lr xDate = scWS.Cells(r, "B").Value If xDate <> "" Then n = Format(DateSerial(2000 + Left(xDate, 2), _ Mid(xDate, 3, 2), _ Right(xDate, 2)), "dd/mm/yyyy") scWS.Cells(r, "D").Value = n End If Next r End Sub  
New Microsoft Excel Worksheet.xlsx

يمكنك  تعديل كود عرض الأعمدة بترتيب العناصر على الشكل التالي 
Private Sub ContrArr(tmp As Long) Dim controls As Variant, columns As Variant, i As Integer controls = Array("TextBox7", "ComboBox1", "ComboBox2", "ComboBox3", "ComboBox4", _ "TextBox3", "TextBox4", "TextBox5", "TextBox6", "ComboBox5") columns = Array(2, 4, 5, 6, 7, 8, 9, 10, 11, 12) If Me.TextBox8.Text = "" Then ClearControls Else Me.TextBox8.Tag = tmp For i = LBound(controls) To UBound(controls) Me.controls(controls(i)).Text = WS.Cells(tmp, columns(i)).Value Next i tblUpdate tmp End If End Sub  
البحث والتنقل.rar

وعليكم السلام ورحمة الله تعالى وبركاته 
جرب هدا 

Private Const Clé As String = "1234" ' قم بتعديل الباسوورد بما يناسبك Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long lastRow = Cells(Rows.Count, "J").End(xlUp).Row ActiveSheet.Unprotect Clé If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing And Target.Columns.Count = 1 Then Application.EnableEvents = False Dim cell As Range For Each cell In Target If cell.Row >= 7 Then cell.Locked = Not IsEmpty(cell.Value) Next cell Application.EnableEvents = True End If ActiveSheet.Protect Clé, UserInterfaceOnly:=True End Sub '================================== Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim lastRow As Long, choose As String: Static OnRng As Range lastRow = Cells(Rows.Count, "J").End(xlUp).Row If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing Then If Not IsEmpty(Target.Value) Then If Target.Locked Then choose = InputBox(": خلية التوقيع محمية الرجاء إدخال كلمة المرور", ":إنتــباه") If choose = Clé Then ActiveSheet.Unprotect Clé If Not OnRng Is Nothing Then OnRng.Locked = True Target.Locked = False Set OnRng = Target ActiveSheet.Protect Clé, UserInterfaceOnly:=True ElseIf choose <> "" Then MsgBox "كلمة المرور غير صحيحة", vbExclamation, "خطأ" End If Else Set OnRng = Target End If Else ActiveSheet.Unprotect Clé Target.Locked = False Set OnRng = Nothing ActiveSheet.Protect Clé, UserInterfaceOnly:=True End If End If End Sub شيت حوافز تجريبى V2.xlsb

For tmp = 6 To Irow If IsNumeric(SrcWS.Cells(tmp, "A").Value) Then SrcWS.Cells(tmp, "A").ClearContents End If Next tmp  
مطلوب ترقيم تلقائى لا يتأثر بحذف الصفوف.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
بإستخدام الأكواد يمكنك تجربة هدا 
Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo ExitApp Application.EnableEvents = False Dim tmp() As Variant, ColArr As Variant, lastRow As Long, _ UnitsArr As Variant, i As Long, j As Integer, tbl As String Dim srcWS As Worksheet: Set srcWS = Me If Not Intersect(Target, Me.Range("I:L")) Is Nothing Then UnitsArr = Array("م²", "سهم", "قيراط", "فدان") With srcWS lastRow = .Columns("I:L").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastRow < 10 Then Exit Sub ColArr = .Range("I10:L" & lastRow).Value ReDim tmp(1 To lastRow - 9, 1 To 1) For i = 1 To UBound(ColArr, 1) tbl = "" For j = 1 To 4 If IsNumeric(ColArr(i, j)) And ColArr(i, j) > 0 Then tbl = tbl & IIf(tbl <> "", " و ", "") & ColArr(i, j) & " " & UnitsArr(j - 1) End If Next j tmp(i, 1) = tbl Next i With .Range("M10:M" & lastRow) .Value = tmp .ReadingOrder = xlRTL End With End With End If ExitApp: Application.EnableEvents = True End Sub  
مساحة.xlsb

هل تقصد حساب عدد الخلايا التي تحتوي على خليط من نصوص وأرقام  مثلا 1م3  او  T5

جرب هدا
Option Explicit Function CalculerVal(rng As Range) As Long Dim cnt As Range, tmp As Long tmp = 0 For Each cnt In rng If cnt.Value <> "" Then If IsNumeric(cnt.Value) Or cnt.Value Like "*[0-9]*" Then tmp = tmp + 1 End If End If Next cnt CalculerVal = tmp End Function في الخلية التي تريد أن تظهر فيها النتيجة مع تعديلها بما يتناسب مع بياناتك الأصلية 
=CalculerVal(B2:H2)  
 
 
مجموع الأرقام مع الحروف.xlsb

Sub test() Dim wsSource As Worksheet, wsPass As Worksheet Dim lastRow As Long, i As Long, passRow As Long Set wsSource = Sheets("Sheet1") Set wsPass = Sheets("Sheet2") Application.ScreenUpdating = False Irow = wsPass.Cells(wsPass.Rows.Count, "G").End(xlUp).Row For j = 4 To Irow Step 2 wsPass.Range("A" & j & ":N" & j).ClearContents Next j lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row passRow = 4 For i = 3 To lastRow If InStr(1, LCase(wsSource.Cells(i, "G").Value), "1/6") > 0 Then wsPass.Cells(passRow, 1).Resize(1, 14).Value = wsSource.Cells(i, 1).Resize(1, 14).Value wsPass.Cells(passRow, 1).Value = passRow - 3 wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat passRow = passRow + 2 End If Next i Application.ScreenUpdating = True End Sub  
test.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
لتحديد حجم كل منتج مع لونه  يمكنك استخدام الصيغة التالية 
=SUMPRODUCT(($B$2:$B$8=$B11)*($C$2:$C$8=C$10)*($D$2:$J$8)) مع سحبها يسارا والى للاسفل على حسب احتياجاتك 
 مجرد اقتراح 
يمكنك أيضا استخراج مجموع كل آلة بشكل منفصل حسب اختيارك  للحصول على مزيد من التفاصيل  وعند اختيار الخيار "الكل" سيتم عرض مجموع جميع الآلات  يمكن القيام بذلك باستخدام الصيغة التالية بعد إضافة قائمة منسدلة تحتوي على أسماء رؤوس الأعمدة الموجودة في الجدول 
=IF($O$10="الكل", SUMPRODUCT(($B$2:$B$8=$M12)*($C$2:$C$8=N$11)*($D$2:$J$8)), IFERROR(SUMIFS(INDEX($D$2:$J$8, 0, MATCH($O$10, $D$1:$J$1, 0)), $B$2:$B$8, $M12, $C$2:$C$8, N$11), 0))
 هدا سيمكنك من استخراج النتائج بعدة طرق يمكنك اختيار ما يناسبك 

 
 
زيرو 2.xlsx

اخي هدا ما يفعله الكود فعلا بعد تعديلك للسطر المشار إليه  
LastRow = 45 اي عدد الصفوف لديك على الملف 

او تثبيتها هنا مباشرة 
WS.Range(WS.Cells(4, tmp), WS.Cells(45, tmp)).Interior.Color = RGB(255, 255, 0)
 
 
جدول الحصص الإضافية 3.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
جرب هل هدا ما تقصده 
Const Main As String = "الرئيسية " Sub destination(WSname As String) Dim WS As Worksheet, f As Worksheet, srcWS As Worksheet Set srcWS = Sheets(Main) Application.ScreenUpdating = False For Each WS In ThisWorkbook.Worksheets If WS.Name = WSname Then Set f = WS Exit For End If Next WS On Error Resume Next For Each WS In ThisWorkbook.Worksheets If WS.Name <> WSname Then WS.Visible = xlSheetVeryHidden Next WS On Error GoTo 0 f.Visible = xlSheetVisible: f.Activate If srcWS.Visible = xlSheetVisible And WSname <> Main Then srcWS.Visible = xlSheetVeryHidden Application.ScreenUpdating = True End Sub Sub GoToMainSheet() Sheets(Main).Visible = xlSheetVisible destination Main End Sub Sub GoToPage1() destination "كشف التلامي الحاضرين صفحة 1" End Sub Sub GoToPage2() destination "كشف التلامي الحاضرين صفحة 2" End Sub Sub GoToPage3() destination "الدخول و الخروج خلال الشهر" End Sub Sub GoToPage4() destination "المعلومات العامة" End Sub وفي حدث ThisWorkbook
Private Sub Workbook_Open() Dim WS As Worksheet Const srcWS As String = "الرئيسية " For Each WS In ThisWorkbook.Worksheets WS.Visible = IIf(WS.Name = srcWS, xlSheetVisible, xlSheetHidden) Next WS End Sub  
كشف التلاميذ الحاضرين 2023--2024.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته
جرب هدا 
Private Sub Worksheet_Change(ByVal Target As Range) Dim srcWS As Worksheet, début As Long, Fin As Long Dim a As Variant, b As Variant, i As Long Set srcWS = Me a = srcWS.[B3].Value b = srcWS.[C3].Value If Not Intersect(Target, srcWS.Range("B3:C3")) Is Nothing Then If a = "" Or b = "" Then Exit Sub If IsNumeric(a) And IsNumeric(b) Then début = a Fin = b If début <= Fin Then srcWS.Range("F7:F" & srcWS.Rows.Count).ClearContents For i = début To Fin srcWS.Cells(6 + i - début + 1, "F").Value = i Next i Else MsgBox _ " بداية الترقيم يجب أن تكون أصغر أو تساوي نهاية الترقيم", vbExclamation, "خطأ في الإدخال" End If End If End If End Sub  بالمعادلات 
=IF(ROW(F7)-ROW($F$7)+$B$3<=$C$3, ROW(F7)-ROW($F$7)+$B$3, "") ترقيم.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
يمكنك إختيار ما يناسبك 
 
Sub CopyRowsmaktab() Dim LR As Long, I As Long, X As Long LR = Sheets("Main").Cells(Rows.Count, "B").End(xlUp).Row X = 6 Application.ScreenUpdating = False Sheets("دريم").Range("B6:G" & Sheets("دريم").Rows.Count).ClearContents For I = 6 To LR If Sheets("Main").Cells(I, "B").Value = "دريم" Then Sheets("دريم").Range("B" & X & ":G" & X).Value = Sheets("Main").Range("B" & I & ":G" & I).Value X = X + 1 End If Next I Application.ScreenUpdating = True End Sub  او
Sub CopyRowsToDream() Dim WS As Worksheet, dest As Worksheet Dim LastRow As Long, n As Long, X As Long Dim WSRng As Range, destRng As Range, Criteria As String Set WS = Sheets("Main") Set dest = Sheets("دريم") Criteria = "دريم" LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row X = 6 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual dest.Range("B6:G" & dest.Rows.Count).ClearContents For n = 6 To LastRow If WS.Cells(n, "B").Value = Criteria Then Set WSRng = WS.Range(WS.Cells(n, "B"), WS.Cells(n, "G")) Set destRng = dest.Range(dest.Cells(X, "B"), dest.Cells(X, "G")) destRng.Value = WSRng.Value X = X + 1 End If Next n Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub او 
Sub CopiesToDream() Dim WS As Worksheet, dest As Worksheet Dim LastRow As Long, n As Long, X As Long Dim Ky As Boolean, WSRng As Range, destRng As Range Set WS = Sheets("Main") Set dest = Sheets("دريم") LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row X = 6 Ky = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For n = 6 To LastRow If WS.Cells(n, "B").Value = "دريم" Then Ky = True Exit For End If Next n If Not Ky Then MsgBox "لا يوجد بيانات مطابقة للنسخ", vbExclamation Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Exit Sub End If dest.Range("B6:G" & dest.Rows.Count).ClearContents For n = 6 To LastRow If WS.Cells(n, "B").Value = "دريم" Then Set WSRng = WS.Range(WS.Cells(n, "B"), WS.Cells(n, "G")) Set destRng = dest.Range(dest.Cells(X, "B"), dest.Cells(X, "G")) destRng.Value = WSRng.Value X = X + 1 End If Next n Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم نسخ البيانات بنجاح", vbInformation End Sub  

ربما هدا ما تقصده 
تجربة فرز الرواتب.xlsx

جرب هدا
Sub DeleteRows() Dim WS As Worksheet, lastRow As Long, i As Long, OnRng As Range Dim choose As VbMsgBoxResult, DataRng As Range, Cnt As Boolean Set WS = Sheets("ورقة1") Set DataRng = WS.Range("A1:E50") lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row Cnt = False For i = 3 To lastRow If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then Cnt = True Exit For End If Next i If Not Cnt Then MsgBox "لا توجد بيانات مطابقة للحذف", vbExclamation, "خطأ" Exit Sub End If choose = MsgBox("هل أنت متأكد أنك تريد حذف من استلمو الاول والثاني ؟", vbYesNo + vbQuestion, "تأكيد الحذف") Application.ScreenUpdating = False If choose = vbYes Then For i = lastRow To 3 Step -1 If WS.Cells(i, 3).Value <> "" And WS.Cells(i, 4).Value <> "" Then If OnRng Is Nothing Then Set OnRng = WS.Rows(i) Else Set OnRng = Union(OnRng, WS.Rows(i)) End If Next i If Not OnRng Is Nothing Then OnRng.Delete For i = 3 To WS.Cells(WS.Rows.Count, "B").End(xlUp).Row WS.Cells(i, 1).Value = i - 2 Next i MsgBox "تم حذف الصفوف بنجاح", vbInformation, "الحذف" With WS .PageSetup.TopMargin = .PageSetup.BottomMargin = .PageSetup.LeftMargin = .PageSetup.RightMargin = Application.InchesToPoints(0.5) .[C1].Value = Format(Date - 1, "dd/mm/yyyy") .[B1].Value = Format(Date - 1, "dddd") End With With DataRng.Font .Name = "Arial": .Size = 16: .Bold = True: .Color = RGB(0, 0, 251) End With Else MsgBox "لا توجد صفوف مطابقة للحذف", vbExclamation, "لم يتم الحذف" End If Else MsgBox "تم إلغاء عملية الحذف", vbInformation, "إلغاء" End If Application.ScreenUpdating = True End Sub  
مثال1 v2.xlsm

اخي @أبوالباسل   دالة VLOOKUP لديها قاعدة أساسية يجب الإنتباه إليها فهي تعمل فقط من اليسار إلى اليمين بمعنى  تبحث دائما في العمود الأول من النطاق المحدد وهو في حالتك العمود G لكنك تريد البحث عن رقم سير باستخدام العمود H (الذي يحتوي على أسماء العملاء)  وهذا يخالف طريقة عمل VLOOKUP لأن العمود  H ليس العمود الأول 
بإختصار  دالة VLOOKUP لا يمكنها البحث في عمود ليس هو الأول ضمن نطاق البيانات لهدا  حاولنا إستخدام بدائل أخرى مثل  INDEX  و MATCH هذه الدوال لا تعتمد على ترتيب الأعمدة 
 للتوضيح أكثر حاول عكس ترتيب الأعمدة بجعل عمود أسماء العملاء  على اليمين وجعل عمود سير يسارا  ووضع المعادلة الخاصة بك على الشكل التالي 
=IF(C3<>"", IFERROR(VLOOKUP(C3, $G$3:$H$121, 2, 0), "غير موجود"), "")
 كما تلاحظ   VLOOKUP  الآن تبحث في العمود H (أسماء العملاء) لأنه أصبح العمود الأول و تسترجع القيمة المقابلة من العمود G (سير ) بنجاح 
 
خط السير-VLOOKUP.xlsx

تفضل أخي تم تعديل الكود السابق وإظافة إمكانية تحديد الأعمدة المرحلة والمرحل إليها لتتمكن من تعديله بما يناسبك لاحقا 
Option Explicit Dim tmp As Variant Const tmpCol As String = "G" Private Sub Worksheet_Change(ByVal Target As Range) Dim arr(3) As Worksheet, OnRng As Range, Irow As Long, ling As Variant Set arr(0) = Sheets("بطاقة صنف"): Set arr(1) = Sheets("اضافة") Set arr(2) = Sheets("الصرف"): Set arr(3) = Sheets("الأصناف") If Not Intersect(Target, Me.Range("J2:I3")) Is Nothing Then SetApp False Set OnRng = arr(0).Range("B6:I" & arr(0).Rows.Count) OnRng.ClearContents Irow = arr(3).Cells(arr(3).Rows.Count, 1).End(xlUp).Row Me.Range("I3").Formula = "=IFERROR(VLOOKUP($J$2,'الأصناف'!$A$3:$B$" & Irow & ",2,0),"""")" Me.Range("I3").Value = Me.Range("I3").Value ling = Me.Range("I3").Value If Not IsEmpty(ling) And ling <> "" Then tmp = ling Call Cnt(arr(1), arr(0), ling, Array(4, 9, 10, 14, 16), Array(3, 5, 6, 4, 2)) Call Cnt(arr(2), arr(0), ling, Array(4, 19, 17, 9, 10, 11), Array(3, 2, 4, 7, 8, 9)) Else OnRng.ClearContents GoTo AppTrue End If AppTrue: SetApp True End If End Sub '"""""""""""""""""""""""""""""""""""" Private Sub Cnt(ByVal dest As Worksheet, ByVal tbl As Worksheet, _ ByVal temp As Variant, ByVal Colky As Variant, ByVal DestCols As Variant) Dim i As Long, x As Long, LastRow As Long, n As Long, Cel As Range, début As Long, fin As Long LastRow = dest.Cells(dest.Rows.Count, tmpCol).End(xlUp).Row début = 3 fin = LastRow For i = début To fin With dest If Not IsEmpty(.Cells(i, tmpCol).Value) And Not IsError(.Cells(i, tmpCol).Value) Then If .Cells(i, tmpCol).Value = temp Then x = WorksheetFunction.CountA(tbl.Range("B6:B1000")) For n = LBound(Colky) To UBound(Colky) Set Cel = tbl.Cells(6 + x, DestCols(n)) Cel.Value = .Cells(i, Colky(n)).Value Next n End If End If End With Next i End Sub '""""""""""""""""""""""""""""" Private Sub SetApp(ByVal Enable As Boolean) Application.ScreenUpdating = Enable Application.EnableEvents = Enable Application.Calculation = IIf(Enable, xlCalculationAutomatic, xlCalculationManual) End Sub  
مخازن 2024مكرو v3.xlsm

نعم أخي يمكنك تعديل السطور الأخيرة من الكود 
Dim fichier As String ' قم بتحديد خلية الإسم بما يناسبك fichier = WS.Range("E30").Value filePath = pdfFolder & "\" & fichier & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Cnt: Next r MsgBox "تم تصدير الملفات إلى مجلد: " & FolderName, vbInformation Unload Me وبما أن ورقة Round 5  تتضمن إسم المستفيد على عمود c يمكنك استخدام هدا ليتم تسمية الملف ديناميكيا عند التنفيد مع مزيدا من التحقق 
Private Sub CommandButton2_Click() Dim r As Long, s As Long, t As Long, FolderName As String, pdfFolder As String, i As Integer Dim filePath As String, ID As String, Item As String, tmp As String, Chars As String If Trim(TextBox1.Value) = "" Or Trim(TextBox2.Value) = "" Or _ Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then MsgBox "الرجاء التحقق من أرقام الإيصالات", vbCritical Exit Sub End If s = CLng(TextBox1.Value): t = CLng(TextBox2.Value) For r = s To t If Trim(dest.Range("B" & r + 2).Value) <> "" Then Exit For Next r If r > t Then: MsgBox "لا يوجد أي إيصالات للحفظ على قاعدة البيانات", vbExclamation: Exit Sub pdfFolder = ThisWorkbook.Path & "\الإيصالات" If Dir(pdfFolder, vbDirectory) = "" Then MkDir pdfFolder Chars = "\ / : * ? "" < > |" For r = s To t ID = Trim(dest.Range("B" & r + 2).Value) '(C)'جلب إسم المستفيد من عمود Item = Trim(dest.Range("C" & r + 2).Value) '(ID)' تجاهل حفظ الملف عند التحقق من عدم وجود إسم المستفيد أو رقم If ID = "" Or Item = "" Then GoTo Cnt tmp = Item For i = 1 To Len(Chars) tmp = Replace(tmp, Mid(Chars, i, 1), "") Next i filePath = pdfFolder & "\" & tmp & ".pdf" WS.[d4] = ID: WS.[U2] = ID On Error Resume Next WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Cnt: Next r MsgBox ": تم تصدير الملفات إلى مجلد" & pdfFolder, vbInformation Unload Me End Sub  
PTT 2024 v3.xlsm

إليك الكود بعد تعديله 
Public Sub FilterAndCopy() Const tmpCol As String = "BC" Dim OnRng As Range, i As Long, n As Long, r As Long Dim WS As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet Set WS = Sheets("اجمالي4") Set Sh1 = Sheets("بنون ناجحون") Set Sh2 = Sheets("بنات ناجحون") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Sh1.Range("A7:BD" & Sh1.Rows.Count).Clear Sh2.Range("A7:BD" & Sh2.Rows.Count).Clear With WS Set OnRng = .Range("A5:BD" & .Cells(.Rows.Count, "A").End(xlUp).Row) End With n = 7: r = 7 For i = 1 To OnRng.Rows.Count + 1 If InStr(1, WS.Cells(i, tmpCol).Value, "ناجح", vbTextCompare) > 0 Then If WS.Cells(i, 9).Value = "ذكر" Then WS.Range("A" & i & ":BD" & i).Copy Destination:=Sh1.Range("A" & n) n = n + 1 ElseIf WS.Cells(i, 9).Value = "انثى" Then WS.Range("A" & i & ":BD" & i).Copy Destination:=Sh2.Range("A" & r) r = r + 1 End If End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub  
 
ترحيل بنون ناجحون وترحيل بنات ناجحات.rar

جرب هدا بعد تنفيد ما سبق دكره سابقا 
Sub CopyDataOnGroups() Dim lastrow&, r&, Irow& Dim ShtOne As Worksheet, WS As Worksheet Dim rng As Boolean, arr As Variant, tmp As Range Dim lingHeader As Range, cell As Range, data As Variant Dim ColHeader As Range, a As Range, OnRng As Range Dim Group As Boolean, n As Boolean Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set ShtOne = Sheets("التجميع") ShtOne.Range("B3:BD" & ShtOne.Rows.Count).Clear arr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5") For Each sheetName In arr Set WS = Sheets(sheetName) lastrow = WS.Columns("B:BD").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastrow < 1 Then GoTo NextSheet For Each lingHeader In WS.Range("B19", WS.Cells(19, WS.Cells(19, Columns.Count).End(xlToLeft).Column)).Cells If lingHeader.MergeCells Then Set lingHeader = lingHeader.MergeArea.Cells(1, 1) For Each tmp In WS.Range(lingHeader.Offset(1, 0), WS.Cells(20, lingHeader.MergeArea.Columns.Count + lingHeader.Column - 1)) Group = False n = False rng = False For Each ColHeader In ShtOne.Range("B1", ShtOne.Cells(1, ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column)).Cells If ColHeader.MergeCells Then Set ColHeader = ColHeader.MergeArea.Cells(1, 1) If Trim(lingHeader.Value) = Trim(ColHeader.Value) Then Group = True For Each a In ShtOne.Range(ColHeader.Offset(1, 0), _ ShtOne.Cells(2, ColHeader.MergeArea.Columns.Count + ColHeader.Column - 1)) If Trim(tmp.Value) = Trim(a.Value) Then n = True Set OnRng = WS.Range(tmp.Offset(1, 0), WS.Cells(lastrow, tmp.Column)) r = ShtOne.Cells(ShtOne.Rows.Count, a.Column).End(xlUp).Row Irow = r + 1 For Each cell In OnRng data = cell.Value If Application.CountIf(ShtOne.Range(ShtOne.Cells(3, a.Column), ShtOne.Cells(r, a.Column)), data) > 0 Then rng = True Exit For End If Next cell If Not rng Then OnRng.Copy ShtOne.Cells(Irow, a.Column).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Application.CutCopyMode = False End If Exit For End If Next a End If If Group And n Then Exit For Next ColHeader Next tmp Next lingHeader NextSheet: Next sheetName Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub  
المصنف 4.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
دالة IF تحتاج إلى شروط واضحة وتنتظر تحديد ما يجب أن يتم في حال كان الشرط صحيحا أو خطأفي حالتك IF "" غير مكتمل لأنك لم تحدد ما يجب تنفيذه في حال كانت الشروط فارغة أو صحيحة
إذا كنت تحاول استخدام دالة IF مع FILTER لتحديد قيمة فارغة مثلا  عند عدم وجود نتائج في FILTER فيمكنك استخدام دالة IFERROR 
=IFERROR(FILTER(AP4:AT353, ISNUMBER(SEARCH(AF6, AQ4:AQ353))), "") مع التأكد من أن الفواصل في الصيغة تتناسب مع الاصدار الموجود لديك  ;  او ,

وعليكم السلام ورحمة الله تعالى وبركاته 
ادا كنت قد إستوعبت طلبك بشكل صحيح فربما هدا سيوفي بالغرض 
ملاحظة : الملف يتضمن عدة أكواد يجب وضع كل كود في مكانه المناسب 
في  Module1 ضع الأكواد التالية
Const a As String = "الرئيسية" Const b As String = "تقرير بالموقع" Const c As String = "تقرير بالمنتج" Public Property Get WS() As Worksheet Set WS = Sheets(a) End Property Public Property Get dest() As Worksheet Set dest = Sheets(b) End Property Public Property Get dest2() As Worksheet Set dest2 = Sheets(c) End Property Sub Run_MainFilter() Call FilterData("J", dest, dest.Range("B2")) Call ApplyBorders(ActiveSheet) End Sub Sub Run_SecondaryFilter() Call FilterData("D", dest2, dest2.Range("B2")) Call ApplyBorders(ActiveSheet) End Sub ' دالة لفلترة البيانات Private Sub FilterData(srcColumn As String, srsWS As Worksheet, Clé As Range) Dim arr() As Variant, dataRange As Range, lastRow As Long Dim Crite As String, ColArr As Long, N As Long, lastCol As Long Crite = Clé.Value lastRow = WS.Cells(WS.Rows.Count, srcColumn).End(xlUp).Row If WS.Range(srcColumn & "3:" & srcColumn & lastRow).Find(Crite, _ LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then MsgBox Crite & " غير موجود", vbExclamation Exit Sub End If Application.ScreenUpdating = False srsWS.Range("A5:J" & srsWS.Rows.Count).ClearContents arr = WS.Range("A3:K" & WS.Cells(WS.Rows.Count, "I").End(xlUp).Row).Value N = 5 For ColArr = 1 To UBound(arr, 1) If arr(ColArr, WS.Range(srcColumn & "1").Column) = Crite Then srsWS.Cells(N, 1).Resize(1, 10).Value _ = Application.Index(arr, ColArr, Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11)) N = N + 1 End If Next ColArr lastCol = srsWS.Cells(5, srsWS.Columns.Count).End(xlToLeft).Column lastRow = srsWS.Cells(srsWS.Rows.Count, "A").End(xlUp).Row srsWS.PageSetup.PrintArea = srsWS.Range("A1", srsWS.Cells(lastRow, lastCol)).Address Application.ScreenUpdating = True End Sub ' تعبئة القائمة المنسدلة تقرير المنتج Sub AddDropdown_Main() Dim Data As Range, destCell As Range Dim lastRow As Long, OnRng As String OnRng = "Dropdown_Main" Set destCell = dest.Range("B2") lastRow = WS.Cells(WS.Rows.Count, "P").End(xlUp).Row Set Data = WS.Range("P2:P" & lastRow) On Error Resume Next ThisWorkbook.Names(OnRng).Delete On Error GoTo 0 ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data With destCell.Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & OnRng .IgnoreBlank = True .InCellDropdown = True End With End Sub ' تعبئة القائمة المنسدلة تفرير بالموقع Sub AddDropdown_Secondary() Dim Data As Range, destCell As Range Dim lastRow As Long, OnRng As String OnRng = "Dropdown_Secondary" Set destCell = dest2.Range("B2") lastRow = WS.Cells(WS.Rows.Count, "O").End(xlUp).Row Set Data = WS.Range("O2:O" & lastRow) On Error Resume Next ThisWorkbook.Names(OnRng).Delete On Error GoTo 0 ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data With destCell.Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & OnRng .IgnoreBlank = True .InCellDropdown = True End With End Sub ' تسطير البيانات Sub ApplyBorders(wsTarget As Worksheet) Dim lastRow As Long, rng As Range lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then Exit Sub Application.ScreenUpdating = False wsTarget.Range("A5:J100").Borders.LineStyle = xlNone Set rng = wsTarget.Range("A5:J" & lastRow) With rng.Borders .LineStyle = xlContinuous .Color = RGB(0, 0, 0) .Weight = xlThin End With Application.ScreenUpdating = True End Sub وفي حدث ورقة الرئيسية 
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim tmp As Object, item As Range, OnRng As Range, ColArr As Range Dim LastRow As Long Application.ScreenUpdating = False If Not Intersect(Target, Me.Columns("D")) Is Nothing Or _ Not Intersect(Target, Me.Columns("J")) Is Nothing Then If Not Intersect(Target, Me.Columns("D")) Is Nothing Then Set ColArr = Me.Range("D3", Me.Cells(Me.Rows.Count, "D").End(xlUp)) Set OnRng = Me.Range("O2:O65000") Else Set ColArr = Me.Range("J3", Me.Cells(Me.Rows.Count, "J").End(xlUp)) Set OnRng = Me.Range("P2:P65000") End If Set tmp = CreateObject("Scripting.Dictionary") For Each item In ColArr If item.Value <> "" Then tmp(item.Value) = "" Next item OnRng.ClearContents If tmp.Count > 0 Then OnRng.Resize(tmp.Count, 1).Value = Application.Transpose(tmp.Keys) End If End If Application.ScreenUpdating = True End Sub في حدث ورقة تقرير بالموقع
Private Sub CommandButton1_Click() Call SaveRangeAsPDF End Sub Private Sub Worksheet_Activate() Call AddDropdown_Secondary End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B2")) Is Nothing Then If Me.Range("B2").Value = "" Then _ MsgBox "برجاء إدخال إسم الموقع ", vbCritical: Exit Sub Call Run_SecondaryFilter End If End Sub وفي حدث ورقة تقرير بالمنتج 
Private Sub CommandButton1_Click() Call SaveRangeAsPDF End Sub Private Sub Worksheet_Activate() Call AddDropdown_Main End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B2")) Is Nothing Then If Me.Range("B2").Value = "" Then _ MsgBox "برجاء إدخال إسم المنتج ", vbCritical: Exit Sub Call Run_MainFilter End If End Sub وأخيرا في موديول جديد الكود الخاص بحفظ الملفات بصيغة PDF
Option Explicit Sub SaveRangeAsPDF() Dim WSdest As Worksheet, sFile As String, folderName As String, sPath As String Dim lastRow As Long, lastCol As Long, pdfPath As String Set WSdest = ActiveSheet sFile = WSdest.Name folderName = "ملفات PDF" sPath = ThisWorkbook.Path & Application.PathSeparator & folderName & Application.PathSeparator On Error Resume Next If Len(Dir(sPath, vbDirectory)) = 0 Then MkDir sPath On Error GoTo 0 lastRow = WSdest.Cells(WSdest.Rows.Count, "A").End(xlUp).Row lastCol = WSdest.Cells(5, WSdest.Columns.Count).End(xlToLeft).Column WSdest.PageSetup.PrintArea = WSdest.Range("A1", WSdest.Cells(lastRow, lastCol)).Address With WSdest.PageSetup .Orientation = xlLandscape .PaperSize = xlPaperA4 .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With pdfPath = sPath & sFile & ".pdf" WSdest.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfPath, Quality:=xlQualityStandard MsgBox "تم حفظ الملف بنجاح", vbInformation End Sub بالتوفيق ............
 
 
جرد المنتج_V2.xlsb