محمد هشام.

وعليكم السلام ورحمة الله تعاللى وبركاته 
أخي @Mharee Accounting Albaig  يفضل دائما إلغاء باسوورد محرر الأكواد  قبل رفع الملف لتفادي إهدار الوقت في كسره 
 
جرب هدا 
Private Sub CommandButton1_Click() On Error GoTo ErrorHandler Dim xlSheet As Worksheet, xlSh As Worksheet, crWS As Worksheet Dim Sht As Worksheet, B As VbMsgBoxResult, T As Long, i As Long, LastCol As Long Set Sht = ThisWorkbook.Sheets("كشف") Set crWS = ThisWorkbook.Sheets("الناسخة ") If Me.BackColor = 192 Or TextBox1.Text = "" Then MsgBox IIf(Me.BackColor = 192, "الاسم مرفوض نصياً", "خلايا فارغة"), vbInformation + vbMsgBoxRight, "تنبيه" Exit Sub End If For Each xlSh In ThisWorkbook.Worksheets If xlSh.Name = Trim(TextBox1.Text) Then MsgBox "اسم مكرر", vbInformation + vbMsgBoxRight, "تنبيه": Exit Sub Next xlSh B = MsgBox("هل تريد اضافة" & vbNewLine & vbNewLine & "الحساب: " & _ TextBox1.Text, vbOKCancel + vbQuestion + vbMsgBoxRight, "تأكيد اضافة حساب") If B = vbCancel Then Exit Sub Application.ScreenUpdating = False Set xlSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) With xlSheet .Name = TextBox1.Text crWS.Range("A1:R74").Copy .Cells.PasteSpecial Paste:=xlPasteAllUsingSourceTheme .Cells.PasteSpecial Paste:=xlPasteColumnWidths ActiveSheet.DisplayRightToLeft = True LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column If LastCol > 18 Then LastCol = 18 .Range(.Cells(1, 1), .Cells(1, LastCol)).AutoFilter .PageSetup.LeftHeader = "كشف حساب " & TextBox1.Text .PageSetup.RightHeader = "اسم الشركة: Bina Puri sdn Bhd" With ActiveWindow .FreezePanes = True .DisplayGridlines = False End With xlSheet.Range("A1").Select End With T = Sht.Range("B" & Sht.Rows.Count).End(xlUp).Row + 1 For i = 1 To ThisWorkbook.Sheets.Count If ThisWorkbook.Sheets(i).Name <> Sht.Name And ThisWorkbook.Sheets(i).Name <> crWS.Name Then Sht.Range("B" & T) = ThisWorkbook.Sheets(i).Name T = T + 1 End If Next i Cleanup: Application.ScreenUpdating = True Set xlSheet = Nothing Set Sht = Nothing Exit Sub ErrorHandler: Resume Cleanup End Sub  
ورقة بالفلتر.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 
الكود الخاص بك  يستخدم  Application.FileSearch
والذي كان مدعوما في Excel 2003 ولكن تم إيقاف دعمه في الإصدارات الأحدث من Excel أعتقد مند 2007  وبالتالي يتطلب تعديلات ليعمل على الإصدارات الأحدث 
جرب هدا 
Private Sub TamamUpdate() Dim val As String, Namey As String, file As String ComboBox28.Clear If OptionButton1.Value = True Then val = ThisWorkbook.Path & "\تمام\مدينة\" ElseIf OptionButton2.Value = True Then val = ThisWorkbook.Path & "\تمام\أكثر\" End If file = Dir(val & "*.xls*") Do While file <> "" Namey = Left(file, InStrRev(file, ".") - 1) ComboBox28.AddItem Namey file = Dir Loop End Sub بطريقة أخرى 
 الكود التالي يؤدي نفس المهمة ولكنه يوفر للمستخدم خيار تحديد المجلد الذي سيتم البحث فيه 
 الكود الخاص بك كان يعتمد على اختيار المجلد بناء على الاختيارات OptionButton1 و OptionButton2 بينما هذا الكود يسمح للمستخدم بتحديد المجلد يدويا باستخدام FileDialog
Private Sub TamamUpdate() Dim val As String, Namey As String Dim fd As FileDialog, tmps As String Set fd = Application.FileDialog(msoFileDialogFolderPicker) If fd.Show = -1 Then tmps = fd.SelectedItems(1) Else Exit Sub End If ComboBox28.Clear val = tmps & "\" file = Dir(val & "*.xls*") Do While file <> "" Namey = Left(file, InStrRev(file, ".") - 1) ComboBox28.AddItem Namey file = Dir Loop End Sub  
 
 
RUN-v2.xls

وعليكم السلام ورحمة الله تعالى وبركاته 
Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim a() As Variant, ColArr As Variant, CelArr As Variant, txt As String, i As Integer, OnRng As Range Dim WS As Worksheet: Set WS = Sheets("النموذج النهائي") Set OnRng = Me.Range("A" & Target.Row & ":AC" & Target.Row) txt = "مؤقت لمدة" If Not Intersect(Target, Me.Range("AD:AD")) Is Nothing And Me.Cells(Target.Row, "AD").Value <> "" Then If InStr(Me.Cells(Target.Row, "AD").Value, "ترحيل") > 0 Then If Application.CountA(OnRng) = 0 Then: MsgBox "لا يوجد بيانات في الصف ", vbExclamation: Exit Sub ColArr = Array("i", "G", "d", "C", "O", "U", "F", "Z") CelArr = Array("L2", "C9", "E13", "G13", "C14", "C15", "C16", "J26") ReDim a(LBound(ColArr) To UBound(ColArr)) For i = LBound(ColArr) To UBound(ColArr): a(i) = Me.Cells(Target.Row, ColArr(i)).Value: Next i WS.[C21].Value = IIf(Me.Cells(Target.Row, "Q").Value <> "", txt & " (" & Me.Cells(Target.Row, "Q").Value & ") سنوات", "") WS.[C22].Value = IIf(IsDate(Me.Cells(Target.Row, "R").Value), Format(Me.Cells(Target.Row, "R").Value, "yyyy/mm/dd"), "") WS.[C23].Value = IIf(IsDate(Me.Cells(Target.Row, "S").Value), Format(Me.Cells(Target.Row, "S").Value, "yyyy/mm/dd"), "") Application.ScreenUpdating = False : Application.EnableEvents = False On Error GoTo SubApp For i = LBound(CelArr) To UBound(CelArr): WS.Range(CelArr(i)).Value = a(i): Next i SubApp: Application.ScreenUpdating = True: Application.EnableEvents = True End If End If End Sub  
طلب ترحيل.xls

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

Option Explicit Dim tmps As Object, cell As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error GoTo ClearApp If Target Is Nothing Then Exit Sub With Me.Shapes("CheckBox1").ControlFormat If .Value = xlOff Then Exit Sub End With If tmps Is Nothing Then Set tmps = CreateObject("Scripting.Dictionary") If Target.Cells.Count > 1 Then Exit Sub For Each cell In Target If Not Intersect(cell, Me.Range("A1:P40")) Is Nothing Then tmps(cell.Address) = cell.Value Next cell ExitHandler: Exit Sub ClearApp: Set tmps = Nothing Resume ExitHandler End Sub Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo ClearApp If Target Is Nothing Or tmps Is Nothing Then Exit Sub With Me.Shapes("CheckBox1").ControlFormat If .Value = xlOff Then Exit Sub End With If Target.Cells.Count > 1 Then Exit Sub Application.EnableEvents = False For Each cell In Target If Not Intersect(cell, Me.Range("A1:P40")) Is Nothing And tmps.exists(cell.Address) Then If IsNumeric(cell.Value) Then cell.Value = tmps(cell.Address) + cell.Value Else MsgBox cell.Address & " : " & "تم إدخال قيمة غير صالحة في الخلية ", vbExclamation End If End If Next cell ExitHandler: Application.EnableEvents = True Exit Sub ClearApp: Resume ExitHandler End Sub  
جمع الخلية v3.xlsb

جرب هل هدا ما تقصده 
Option Explicit Sub Split_names() Dim tbl&, tmp&, i&, Max&, c&, j&, lr&, r&, s& Dim n As String, ky As Boolean, ColArr As Range, OnRng As Range Dim Arr As Variant, rng As Variant, sp As Variant, Choisir As VbMsgBoxResult Dim WS As Worksheet: Set WS = Sheets("حساب الفوائد") Dim dest As Worksheet: Set dest = Sheets("مؤشر الفائدة") Dim ColNam As String: ColNam = "DM" Choisir = MsgBox("تحديث البيانات ؟", vbYesNo + vbQuestion, "تأكيد") If Choisir <> vbYes Then Exit Sub Max = 444 With Application .ScreenUpdating = False .Calculation = xlCalculationManual .ErrorCheckingOptions.BackgroundChecking = True End With On Error Resume Next tbl = WS.Columns("T:CC").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 tbl = WorksheetFunction.Min(WorksheetFunction.Max(tbl, 14), Max) WS.Range("DJ14:DJ" & tbl).ClearContents Set OnRng = WS.Range("T14:CC" & tbl) Arr = OnRng.Value For tmp = 1 To UBound(Arr, 1) n = "" ky = False For i = 1 To UBound(Arr, 2) If Arr(tmp, i) <> "" Then n = IIf(n = "", WS.Cells(dest.Range("AT6").Value, i + 19).Text, n & "*" & WS.Cells(dest.Range("AT6").Value, i + 19).Text) If Not ky Then WS.Cells(tmp + 13, 114).NumberFormat = WS.Cells(tmp + 13, i + 19).NumberFormat ky = True End If End If Next i WS.Cells(tmp + 13, 114).Value = n Next tmp On Error Resume Next Set ColArr = WS.Range("DG14:DG" & tbl).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not ColArr Is Nothing Then Arr = ColArr.Value ReDim rng(1 To UBound(Arr, 1), 1 To 1) For c = 1 To UBound(Arr, 1) rng(c, 1) = Arr(c, 1) Next c WS.Range("DM14").Resize(UBound(rng, 1), 1).Value = rng End If dest.Range("AS2") = 2 dest.Range("I6:AL105").ClearContents lr = WS.Cells(WS.Rows.Count, ColNam).End(xlUp).Row WS.Range("DN14:EQ" & WS.Rows.Count).ClearContents Arr = WS.Range(ColNam & "14:" & ColNam & lr).Value For j = 1 To UBound(Arr, 1) sp = Split(Arr(j, 1), "*") For r = LBound(sp) To UBound(sp) WS.Cells(j + 13, r + 118).NumberFormat = "@" WS.Cells(j + 13, r + 118).Value = sp(r) Next r Next j For s = 9 To 38 dest.Columns(s).EntireColumn.Hidden = (dest.Cells(5, s).Value = 0) Next s With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .ErrorCheckingOptions.BackgroundChecking = False End With End Sub  
 
نسب ومؤشر الفائدة v4.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
=IFERROR(VLOOKUP(E13, $Q$12:$U$14, MATCH(D13, $Q$11:$U$11, 0), FALSE), "")  

New Microsoft Excel Worksheet.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته 
Sub MergeTotal() Dim WS As Worksheet, crWS As Worksheet, LastRow As Long, Irow As Long On Error Resume Next Set crWS = Sheets("total") On Error GoTo 0 If crWS Is Nothing Then MsgBox " غير موجودة total ورقة ", vbInformation Exit Sub Else Application.ScreenUpdating = False crWS.Range("A2:O" & crWS.Rows.Count).Clear End If Irow = 2 For Each WS In ThisWorkbook.Sheets If WS.Name <> crWS.Name Then LastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If LastRow >= 2 Then WS.Range("A2:O" & LastRow).Copy crWS.Cells(Irow, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Irow = crWS.Cells(crWS.Rows.Count, 1).End(xlUp).Row + 1 End If End If Next WS Application.CutCopyMode = False Application.ScreenUpdating = True End Sub or
Sub MergeTotal() Dim WS As Worksheet, Src As Worksheet Dim OnRng As Variant, rng As Range, r As Range Dim lastRow As Long, tmp As Long, col As Integer Set WS = Sheets("total") Application.ScreenUpdating = False lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row If lastRow > 1 Then: WS.Rows("2:" & lastRow).Clear tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 For Each Src In ThisWorkbook.Sheets If Src.Name <> WS.Name Then OnRng = Src.Range("A2:O" & Src.Cells(Src.Rows.Count, "A").End(xlUp).Row).Value WS.Cells(tmp, 1).Resize(UBound(OnRng, 1), UBound(OnRng, 2)).Value = OnRng For lastRow = 1 To Src.Cells(Src.Rows.Count, "A").End(xlUp).Row WS.Rows(tmp + lastRow - 1).RowHeight = 18.5 Next lastRow tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 End If Next Src With WS.Range("A1:O" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row) .Borders.LineStyle = xlContinuous: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Application.ScreenUpdating = True End Sub الرواتب.xlsb

تفضل جرب هدا التعديل  
Option Explicit Sub test() Dim wbDest As Workbook, wbData As Workbook Dim WS As Worksheet, CrWS As Worksheet Dim Irow&, nRow&, xPath$, xFile$, fname As Variant Dim i, j, k As Integer, ShArr As Variant, OnRng, tmps As Range Dim WSIndex As Integer SetApp False xPath = ThisWorkbook.Path fname = Array("رصيد التوكيلات1.xlsx", "رصيد التوكيلات_كفرالشيخ.xlsx", "رصيد التوكيلات_البحيرة.xlsx", _ "رصيد التوكيلات_طنطا.xlsx", "رصيد التوكيلات_المنصورة.xlsx", "رصيد التوكيلات_دكرنس.xlsx", _ "رصيد التوكيلات_دمياط.xlsx", "رصيد التوكيلات_المنوفية.xlsx", "رصيد التوكيلات_الشرقية.xlsx", _ "رصيد التوكيلات_الاسماعيلية.xlsx", "رصيد التوكيلات_بور سعيد.xlsx", "رصيد التوكيلات_السويس.xlsx", _ "رصيد التوكيلات_المقطم.xlsx", "رصيد التوكيلات_مؤسسة الزكاة.xlsx", "رصيد التوكيلات_الجيزة.xlsx", _ "رصيد التوكيلات_القليوبية.xlsx", "رصيد التوكيلات_الفيوم.xlsx", "رصيد التوكيلات_بنى سويف.xlsx", _ "رصيد التوكيلات_المنيا.xlsx", "رصيد التوكيلات_اسيوط.xlsx", "رصيد التوكيلات_سوهاج.xlsx", _ "رصيد التوكيلات_جرجا.xlsx", "رصيد التوكيلات_قنا.xlsx", "رصيد التوكيلات_نجع حمادى.xlsx", _ "رصيد التوكيلات_الغردقة.xlsx", "رصيد التوكيلات_الاقصر.xlsx", "رصيد التوكيلات_اسوان.xlsx", _ "رصيد التوكيلات_ادفو.xlsx") ShArr = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _ "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _ "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _ "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الاقصر", "اسوان", "ادفو") Set wbData = ThisWorkbook On Error Resume Next Set wbDest = Workbooks.Open(xPath & "\" & fname(0), ReadOnly:=True) If wbDest Is Nothing Then MsgBox "تعذر العثور على الملف " & fname(0), vbCritical SetApp True Exit Sub End If On Error GoTo 0 For WSIndex = LBound(fname) To UBound(fname) xFile = xPath & "\" & fname(WSIndex) On Error Resume Next Set wbDest = Workbooks.Open(xFile, ReadOnly:=True) If wbDest Is Nothing Then MsgBox "تعذر العثور على الملف " & fname(WSIndex), vbCritical SetApp True Exit Sub End If On Error GoTo 0 For i = LBound(ShArr) To UBound(ShArr) On Error Resume Next Set CrWS = wbData.Sheets(ShArr(i)) On Error GoTo 0 If Not CrWS Is Nothing Then Set WS = Nothing On Error Resume Next Set WS = wbDest.Sheets(ShArr(i)) On Error GoTo 0 If Not WS Is Nothing Then Irow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row If Irow < 4 Then GoTo SkipSheet End If For j = 6 To 19 Set tmps = CrWS.Cells(3, j) For k = 6 To 19 Set OnRng = WS.Cells(3, k) If OnRng.Value = tmps.Value And Not IsEmpty(OnRng.Value) Then For nRow = 4 To 71 If Not IsEmpty(WS.Cells(nRow, k).Value) Then CrWS.Cells(nRow, j).Value = WS.Cells(nRow, k).Value End If Next nRow Exit For End If Next k Next j For nRow = 4 To 71 If Not IsEmpty(WS.Cells(nRow, 2).Value) Then CrWS.Cells(nRow, 2).Value = WS.Cells(nRow, 2).Value End If Next nRow End If End If SkipSheet: Next i SkipFile: wbDest.Close False Next WSIndex MsgBox "تم نقل البيانات من جميع الملفات بنجاح", vbInformation SetApp True End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next Application.ScreenUpdating = enable Application.EnableEvents = enable Application.DisplayAlerts = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End Sub  
نقل البيانات من مصنفات متعددة.rar

نعم أخي فقط قم بتعديل السطور التالية  
With tbl .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter .Rows.Alignment = wdAlignRowCenter .Borders.Enable = True Dim ColArr As Variant: ColArr = Array(80, 80, 200, 80, 80) For i = 0 To UBound(ColArr) .Columns(i + 1).PreferredWidth = ColArr(i) Next i End With تم  تعديل الكود على الملف المرفق  مع إظافة إمكانية حفظ الملف بصيغة PDF عند الحاجة 

 
 
ملف تصدير V4.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته
لست متأكدا من طلبك لاكن حاول تجربة هدا 
Option Explicit Private Const n As Long = 25 Private Const rHeight As Double = 20 Private Const tmps As Integer = 4 Private Const Col As String = "B" Sub PrintWS() Dim lr As Long, i As Long Dim lastCol As Long, OnRng As Range Dim CrWS As Worksheet Dim ColNum As Long Set CrWS = Sheets("Data") Application.ScreenUpdating = False CrWS.ResetAllPageBreaks Application.ActiveWindow.View = xlPageBreakPreview ColNum = CrWS.Range(Col & "1").Column lr = CrWS.Range(Col & CrWS.Rows.count).End(xlUp).Row CrWS.Rows("5:" & lr).RowHeight = rHeight If lr > tmps + n Then For i = tmps + n + 1 To lr Step n CrWS.HPageBreaks.Add Before:=CrWS.Rows(i) Next i End If lastCol = CrWS.Cells(tmps, CrWS.Columns.count).End(xlToLeft).Column Set OnRng = CrWS.Range(CrWS.Cells(tmps, ColNum), CrWS.Cells(lr, lastCol)) CrWS.PageSetup.PrintArea = OnRng.Address CrWS.VPageBreaks.Add Before:=CrWS.Columns(lastCol + 1) CrWS.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 With CrWS.PageSetup .Orientation = xlPortrait: .PaperSize = xlPaperA4 .FitToPagesWide = 1: .FitToPagesTall = False End With Application.ScreenUpdating = True End Sub  
Test V1.xlsb

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

Option Explicit Dim WS As Worksheet Dim OnRng As Variant Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set WS = Sheets("Sheet1") If Not Intersect([A2:A11], Target) Is Nothing And Target.Count = 1 Then OnRng = WS.Range("C2:C" & WS.Cells(WS.Rows.Count, "C").End(xlUp).Row).value Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.Height = Target.Height + 3 Me.ComboBox1.Width = Target.Width Me.ComboBox1.Top = Target.Top Me.ComboBox1.Left = Target.Left Me.ComboBox1.value = Target.value Me.ComboBox1.Visible = True Me.ComboBox1.Activate Else Me.ComboBox1.Visible = False End If End Sub Private Sub ComboBox1_Change() If Me.ComboBox1.value <> "" Then Dim d1 As Object Set d1 = CreateObject("Scripting.Dictionary") Dim tmp As String tmp = UCase(Me.ComboBox1.value) & "*" Dim i As Long For i = 1 To UBound(OnRng, 1) If UCase(OnRng(i, 1)) Like tmp Then d1(OnRng(i, 1)) = "" Next i Me.ComboBox1.List = d1.Keys Me.ComboBox1.DropDown End If ActiveCell.value = Me.ComboBox1.value End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Me.ComboBox1.List = Application.Transpose(OnRng) 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 If End Sub  
قائمة منسدلة مع البحث والاكمال التلقائي.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
جرب هدا
Option Explicit Sub test() Dim wbDest As Workbook, wbData As Workbook Dim WS As Worksheet, CrWS As Worksheet Dim Irow&, lastCol&, nRow&, xPath$, xFile$, fname$ Dim i, j, k As Integer, ShArr As Variant, OnRng, tmps As Range SetApp False xPath = ThisWorkbook.Path fname = "رصيد التوكيلات1" xFile = xPath & "\" & fname & ".xlsx" If Dir(xFile) = "" Then MsgBox "تعذر العثور على الملف " & fname, vbCritical SetApp True Exit Sub End If Set wbData = ThisWorkbook ShArr = Array("الاسكندرية", "كفرالشيخ", "البحيرة", "طنطا", "المنصورة", "دكرنس", _ "دمياط", "المنوفية", "الشرقية", "الاسماعيلية", "بور سعيد", "السويس", _ "المقطم", "مؤسسة الزكاة", "الجيزة", "القليوبية", "الفيوم", "بنى سويف", _ "المنيا", "اسيوط", "سوهاج", "جرجا", "قنا", "نجع حمادى", "الاقصر", "اسوان", "ادفو") On Error Resume Next Set wbDest = Workbooks.Open(xFile, ReadOnly:=True) If wbDest Is Nothing Then SetApp True Exit Sub End If On Error GoTo 0 For i = LBound(ShArr) To UBound(ShArr) On Error Resume Next Set WS = wbDest.Sheets(ShArr(i)) Set CrWS = wbData.Sheets(ShArr(i)) On Error GoTo 0 If Not WS Is Nothing And Not CrWS Is Nothing Then Irow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row If Irow >= 4 Then For j = 6 To 19 Set tmps = CrWS.Cells(3, j) For k = 6 To 19 Set OnRng = WS.Cells(3, k) If OnRng.Value = tmps.Value And Not IsEmpty(OnRng.Value) Then For nRow = 4 To 71 If Not IsEmpty(WS.Cells(nRow, k).Value) Then CrWS.Cells(nRow, j).Value = WS.Cells(nRow, k).Value End If Next nRow Exit For End If Next k Next j For nRow = 4 To 71 If Not IsEmpty(WS.Cells(nRow, 2).Value) Then CrWS.Cells(nRow, 2).Value = WS.Cells(nRow, 2).Value End If Next nRow End If End If Next i wbDest.Close False Cleanup: SetApp True MsgBox "تم نقل البيانات بنجاح", vbInformation End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next Application.ScreenUpdating = enable Application.EnableEvents = enable Application.DisplayAlerts = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End Sub  
 
نقل البيانات بين الملفات.rar

وعليكم السلام ورحمة الله نعالى وبركاته
دالة IFS هي دالة موجودة في إصدارات Excel الحديثة ولكنها غير مدعومة في Excel 2019  يمكنك استخدام دوال أخرى مثل IF المتداخلة لتحقيق نفس الوظيفة على سبيل المثال
=IF(A2="","",IF(A2<5,"ضعيف",IF(A2<10,"متوسط",IF(A2<15,"حسن","ممتاز")))) أو 
=IF(A2="","",CHOOSE(MATCH(A2,{0,5,10,15},1),"ضعيف","متوسط","حسن","ممتاز"))  
يمكنك تعديل هذه الصيغ لتشمل العديد من الشروط المتداخلة حسب حاجتك 
 
إذا كنت ترغب في محاكاة دالة IFS باستخدام VBA يمكننا كتابة دالة مخصصة تقوم بالتحقق من عدة شروط في تسلسل مشابه لدالة IFS  في Module قم بلصق الكود التالي
Function IFS_Formula(ParamArray tmp() As Variant) As Variant Dim i As Integer For i = LBound(tmp) To UBound(tmp) Step 2 If tmp(i) Then IFS_Formula = tmp(i + 1) Exit Function End If Next i IFS_Formula = CVErr(xlErrValue) End Function واستخدام الدالة التالية 
=IFS_Formula(A2="","",A2<5,"ضعيف",A2<10,"متوسط",A2<15,"حسن",A2>=15,"ممتاز")  
 
في حالة لديك حاجة مستمرة لاستخدام دالة IFS فإن الحل الأكثر فعالية سيكون الترقية إلى  Excel 2021
رابط التحميل 
https://www.mediafire.com/file/2iky3sdt2ojv6ag/Office_2016-2021-x86_x64-EN_FR.M-HICHAM.rar/file
حيث تكون هذه الدالة مدعومة بشكل كامل
بالتوفيق.............
 
TEST-IFS.xlsb

أخي  @بلانك فعلا الأكواد المقترحة لا تضع الخطوط  وإنما لحدفها  الاول لحدف الخطوط والثاني لحدف الاشكال لأنني لاحظت أنك إستخدمتها في ملفك المرفق في أول مشاركة   
هدا ما فهمت من طلبك الأخير 
 
رغم أن الكود الأول تم تزويدك به مسبقا جرب هدا 
Option Explicit Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property Sub add_Underline() Dim lastRow As Long, OnRng As Variant, i As Long Dim Max As Integer Max = 20 Application.EnableEvents = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row OnRng = WS.Range("C3:C" & lastRow).Value For i = 1 To UBound(OnRng, 1) With WS.Cells(i + 2, "C") If IsNumeric(OnRng(i, 1)) And OnRng(i, 1) < Max Then .Font.Underline = xlUnderlineStyleSingle .Font.Color = RGB(255, 0, 0) Else .Font.Underline = xlUnderlineStyleNone .Font.Color = RGB(0, 0, 0) End If End With Next i Application.EnableEvents = True Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub '============================= Sub Supprimer_lignes() Dim lastRow As Long, i As Long lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row For i = 4 To lastRow WS.Cells(i, "C").Font.Underline = xlUnderlineStyleNone WS.Cells(i, "C").Font.Color = RGB(0, 0, 0) Next i End Sub
كود لعمل خط تحت الدرجة الاقل V2.xlsb

تفضل أخي 
test2.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته 
رغم أنني ليس متأكدا من طلبك بسبب كثرة الأكواد التي قمت بإرفاقها  
 بالنسبة لعمود  F   (اجمالى ك وق)  لا يمكن جمع القيم مباشرة إذا كانت مخزنة كنص باستخدام الدالة TEXT  أعتقد انه يمكنك تجاوز هذه المشكلة بتعديل الكود  لجمع القيم العددية مباشرة دون الحاجة إلى الصيغة TEXT  مع الاحتفاظ بالصيغ في الأعمدة الأخرى 
Option Explicit Sub Test() Dim WS As Worksheet, dest As Worksheet, dict As Object Dim Code, name, Unit As String Dim cartn, Price, tmp, ColF As Double Dim ColArr, col, key, ColHard As Variant Dim lastRow, i, Irow As Long Set WS = Sheets("Sheet3"): Set dest = Sheets("رصيد") lastRow = WS.Cells(Rows.Count, 7).End(xlUp).Row If lastRow < 2 Then Exit Sub ColHard = Array("كود الصنف", "اسم الصنف", "وحدة الصنف", "سعر الصنف", "عدد الكراتين", "إجمالي ك وق", "ك", "ق") With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With dest.Range("A2:H" & dest.Rows.Count).ClearContents Application.ErrorCheckingOptions.BackgroundChecking = False Set dict = CreateObject("Scripting.Dictionary") Irow = 2 For i = 2 To lastRow Code = Trim(CStr(WS.Cells(i, 7).value)) name = Trim(WS.Cells(i, 6).value) Unit = Trim(WS.Cells(i, 4).value) Price = Val(WS.Cells(i, 5).value) cartn = Val(WS.Cells(i, 3).value) If Code <> "" Then If dict.Exists(Code) Then dict(Code)(3) = dict(Code)(3) + cartn Else dict.Add Code, Array(name, Unit, Price, cartn) End If End If Next i With dest .Range("A1:H1").value = ColHard For Each key In dict.Keys .Cells(Irow, 1).value = key .Cells(Irow, 2).Resize(1, 4).value = dict(key) .Cells(Irow, 7).Formula = "=INT(E" & Irow & "/C" & Irow & ")" .Cells(Irow, 8).Formula = "=MOD(E" & Irow & ",C" & Irow & ")" Irow = Irow + 1 Next key .Cells(Irow, 1).value = "المجموع الكلي" ColF = 0 For i = 2 To Irow - 1 If .Cells(i, 5).value <> 0 And .Cells(i, 3).value <> 0 Then tmp = Int(.Cells(i, 5).value / .Cells(i, 3).value) + (.Cells(i, 5).value Mod _ .Cells(i, 3).value) / .Cells(i, 3).value Else tmp = 0 End If .Cells(i, 6).value = Format(tmp, "0.0") ColF = ColF + tmp Next i .Cells(Irow, 6).value = Format(ColF, "0.0") ColArr = Array("E", "G", "H") For Each col In ColArr .Cells(Irow, col).Formula = "=SUM(" & col & "2:" & col & (Irow - 1) & ")" Next col End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With MsgBox "تمت العملية بنجاح", vbInformation End Sub  
اجمالى2 V1.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته  
جرب هدا  مع سحب المعادلة للأسفل 
=IFERROR(INDEX(INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2); MATCH(0;COUNTIF($B$1:B2; INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2)) + IF(INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2) = ""; 1; 0); 0)); "") في حالة إستخدامك لنسخة أوفيس حديثة 
=IFERROR(UNIQUE(INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2)); "")  

وعليكم السلام ورحمة الله تعالى وبركاته 
جرب هدا 
Option Explicit Sub SplitData() Dim crWS As Worksheet, dest As Worksheet, OnRng As Variant, data As Variant Dim n As Integer, x As Integer, MonthArr As String, sDate As Date Dim lastRow As Long, i As Long, Irow As Long, lr As Long Dim f As Worksheet, arr As Variant, v As Variant: Set crWS = Sheets("العقود") arr = Array("العقود", "") ' في حالة وجود أوراق أخرى يجب الإحتفاظ بها قم بإظافتها هنا lastRow = crWS.Cells(crWS.Rows.Count, "J").End(xlUp).Row If lastRow < 5 Then: Exit Sub With Application .ScreenUpdating = False: .DisplayAlerts = False End With Application.ErrorCheckingOptions.BackgroundChecking = True For Each f In ThisWorkbook.Worksheets If f.Name <> crWS.Name Then v = Application.Match(f.Name, arr, 0) If IsError(v) Then: f.Delete End If Next f OnRng = crWS.Range("J4:J" & lastRow).Value For i = 1 To UBound(OnRng, 1) If InStr(OnRng(i, 1), ":") > 0 Then OnRng(i, 1) = Replace(OnRng(i, 1), ":", "/") Next i crWS.Range("J4:J" & lastRow).Value = OnRng For i = 1 To UBound(OnRng, 1) If Len(OnRng(i, 1)) > 0 Then If IsDate(OnRng(i, 1)) Then sDate = CDate(OnRng(i, 1)): n = Month(sDate): x = Year(sDate) MonthArr = Choose(n, "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") Set dest = tmp(MonthArr & " " & x, crWS.Rows(4)) Irow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 data = crWS.Range("B" & (i + 3) & ":N" & (i + 3)).Value dest.Range("B" & Irow).Resize(1, UBound(data, 2)).Value = data With dest.Range("A5:A" & dest.Cells(dest.Rows.Count, "J").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-4") End With With dest lr = .Columns("A:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row .Columns("A:M").AutoFit .Rows("5:" & lr).RowHeight = 25.5 .Range("A5:M" & lr).HorizontalAlignment = xlCenter .Range("A5:M" & lr).VerticalAlignment = xlCenter .Range("J5:J" & lr).NumberFormat = "dd/mm/yyyy" End With End If End If Next i crWS.Activate With Application .ScreenUpdating = True: .DisplayAlerts = True End With MsgBox "تم تقسيم الموظفين بنجاح", vbInformation End Sub Function tmp(ShName As String, header As Range) As Worksheet Dim WS As Worksheet On Error Resume Next Set WS = ThisWorkbook.Sheets(ShName) On Error GoTo 0 If WS Is Nothing Then Set WS = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Name = ShName WS.DisplayRightToLeft = True header.Copy WS.Rows(4) End If Set tmp = WS End Function  
العقود v2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته
Option Explicit Sub kh_Color1() Dim Obj As Object, MyColor As Long, lr As Long, R As Long, txt As String Dim WS As Worksheet: Set WS = Sheets("قيود اليومية") Application.ScreenUpdating = False Set Obj = CreateObject("Scripting.Dictionary") MyColor = 900000 lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row WS.Range("A6:J" & lr).Interior.color = 800444 For R = 6 To lr txt = Trim(WS.Cells(R, "G")) If Len(txt) Then If Not Obj.Exists(txt) Then Obj.Add txt, MyColor MyColor = MyColor + 7000111 End If WS.Range(WS.Cells(R, "A"), WS.Cells(R, "J")).Interior.color = Obj(txt) Dim rColor As Long, gColor As Long, bColor As Long rColor = (Obj(txt) Mod 256) gColor = ((Obj(txt) \ 256) Mod 256) bColor = ((Obj(txt) \ 65536) Mod 256) If (rColor + gColor + bColor) / 3 < 128 Then WS.Cells(R, "A").Resize(1, 10).Font.color = RGB(255, 255, 255) Else WS.Cells(R, "A").Resize(1, 10).Font.color = RGB(0, 0, 0) End If End If Next R Set Obj = Nothing Application.ScreenUpdating = True End Sub  

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