محمد هشام.

وعليكم السلام وحمة الله تعالى وبركاته 
يمكنك تعديله بما يناسبك 
Option Explicit Sub sav_PDFall() ActiveSheet.Unprotect Password:="saaa" Dim i As Integer Dim folderPath As String folderPath = ThisWorkbook.Path & "\الشهادات" If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath End If For i = 1 To Range("u1") Step 3 Range("h1") = i If i <= Range("u1") Then ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=folderPath & "\" & Range("H1").Value & ".pdf", Quality:=xlQualityMinimum, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End If Next i ActiveSheet.Protect Password:="saaa" End Sub  

إدا كنت قد إستوعبت طلبك بشكل صحيح ربما هدا سيوفي بالغرض  
 
Option Explicit Sub CreateDossiers() Dim a As Variant, lastRow As Long, i As Long, msg As String Dim Dossiers As String, Fld As String, Patch As String Dim nCarte As String, nEmploy As String, tyCont As String Dim tbl As Object, Fname As String, fCount As Integer Dim ScrWS As Worksheet: Set ScrWS = Sheets("ورقة1") Set tbl = CreateObject("Scripting.Dictionary") lastRow = ScrWS.Cells(ScrWS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then Exit Sub a = ScrWS.Range("B2:D" & lastRow).Value Dossiers = ThisWorkbook.Path & "\" Fld = Dossiers & "عقد ثابت\" Patch = Dossiers & "عقد مؤقت\" If Dir(Dossiers, vbDirectory) = "" Then MkDir Dossiers If Dir(Fld, vbDirectory) = "" Then MkDir Fld If Dir(Patch, vbDirectory) = "" Then MkDir Patch For i = 1 To UBound(a, 1) If Trim(a(i, 3)) = "ثابت" Then tbl(Trim(a(i, 1)) & " - " & Trim(a(i, 2))) = "ثابت" End If Next i fCount = 0 For i = 1 To UBound(a, 1) nCarte = Trim(a(i, 1)): nEmploy = Trim(a(i, 2)): tyCont = Trim(a(i, 3)) If nCarte <> "" And IsNumeric(nCarte) And nEmploy <> "" And tyCont <> "" Then Fname = nCarte & " - " & nEmploy If tbl.Exists(Fname) Then If Dir(Fld & Fname, vbDirectory) = "" Then MkDir Fld & Fname fCount = fCount + 1 End If Else If Dir(Patch & Fname, vbDirectory) = "" Then MkDir Patch & Fname fCount = fCount + 1 End If End If End If Next i msg = IIf(fCount > 0, "تم إنشاء " & fCount & " من المجلدات بنجاح", "جميع المجلدات موجودة مسبقا") MsgBox msg, vbInformation End Sub  
 
عقود V2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
lr = Cells(Rows.Count, 2).End(3).Row تحديد رقم الصف الأخير في العمود B الذي يحتوي على بيانات 
End(3) هي اختصار للخاصية xlUp التي تعني التحرك صعودا في العمود  حتى تصل إلى أول خلية تحتوي على بيانات  
 
    x =  الصف الذي يبدأ منه النطاق المحدد
 
Set my_rg = Range("A" & x & ":A" & lr).SpecialCells(4) لتحديد الخلايا داخل نطاق معين و هو اختصار للخاصية  xlCellTypeBlanks التي تعني الخلايا الفارغة  
 
 إدن بعد تحديد صف بداية النطاق وليكن مثلا الصف 5
الكود
Option Explicit Sub test() Dim lr As Long, x As Long, my_rg As Range On Error Resume Next lr = Cells(Rows.Count, 2).End(3).Row x = 5 Set my_rg = Range("A" & x & ":A" & lr).SpecialCells(4) If Not my_rg Is Nothing Then my_rg.EntireRow.Delete End If On Error GoTo 0 End Sub لنفترض ان اخر خلية في العمود B هي 100  إذا كان هناك خلايا فارغة في العمود A ضمن النطاق  A5:A100 سيتم حذف الصفوف التي تحتوي على هذه الخلايا  مع تجاهل الخلايا التي تتضمن قيم أو معادلات 

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

وعليكم السلام ورحمة الله تعالى وبركاته 
جرب هدا
حفظ الملفات في تفس مسار الملف 
Option Explicit Sub SAVE_PDF() Dim ScWS As Variant, Path As String, i As Integer ScWS = Array("Sheet1", "Sheet2", "Sheet3") Path = ThisWorkbook.Path & "\" If Path = "\" Then Exit Sub For i = LBound(ScWS) To UBound(ScWS) If Not ShExists(ScWS(i)) Then MsgBox "الورقة " & ScWS(i) & " غير موجودة": Exit Sub Application.ScreenUpdating = False On Error Resume Next Sheets(ScWS(i)).ExportAsFixedFormat Type:=xlTypePDF, FileName:=Path & ScWS(i) & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Next i Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح" End Sub لإنشاء مجلد وحفظ الملفات بداخله
Sub SAVE_PDF_Folder() Dim ScWS As Variant, Path As String, Dossier As String, i As Integer ScWS = Array("Sheet1", "Sheet2", "Sheet3") Path = ThisWorkbook.Path & "\" Dossier = "ملفات PDF" If Path = "\" Then Exit Sub If Dir(Path & Dossier, vbDirectory) = "" Then MkDir Path & Dossier Path = Path & Dossier & "\" For i = LBound(ScWS) To UBound(ScWS) If Not ShExists(ScWS(i)) Then MsgBox "الورقة " & ScWS(i) & " غير موجودة": Exit Sub Application.ScreenUpdating = False On Error Resume Next Sheets(ScWS(i)).ExportAsFixedFormat Type:=xlTypePDF, FileName:=Path & ScWS(i) & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Next i Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح" End Sub Function ShExists(ByVal SheetName As String) As Boolean On Error Resume Next: ShExists = Not Sheets(SheetName) Is Nothing: On Error GoTo 0 End Function  
 
حفظ الملفات مستقلة بصيغة PDF.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
جرب هدا 
في Module  ضع الكود التالي 
Sub ColoriageDoublons() Dim WSarr As Variant, couleurs As Long, d As Object, _ s As Variant, OnRng As Range, lastRow As Long, a, i As Long WSarr = Array(1, 2, 3): couleurs = RGB(0, 204, 255) Set d = CreateObject("Scripting.Dictionary") For Each s In WSarr With Sheets(s) lastRow = .Cells.Find(What:="*", LookIn:=xlValues, _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row a = .Range("C4:C" & lastRow).Value For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then d(a(i, 1)) = d(a(i, 1)) + 1 Next i End With Next s For Each s In WSarr With Sheets(s) lastRow = .Cells.Find(What:="*", LookIn:=xlValues, _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set OnRng = .Range("C4:C" & lastRow) a = OnRng.Value For i = 1 To UBound(a, 1) OnRng.Cells(i).Interior.Color = IIf(a(i, 1) <> "" And d(a(i, 1)) > 1, couleurs, xlNone) Next i End With Next s End Sub وفي حدث ThisWorkbook
Option Explicit Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim WSarr As Variant WSarr = Array("1", "2", "3") If Not Intersect(Target, Sh.Columns("C")) Is Nothing And Target.Row >= 4 Then Application.ScreenUpdating = False If Not IsError(Application.Match(Sh.Name, WSarr, 0)) Then Call ColoriageDoublons End If Application.ScreenUpdating = True End If End Sub  
 
 
تلوين الخلايا v2 المكررة.xlsm

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