محمد هشام.

وعليكم السلام ورحمة الله وبركاته
أخي @ابو نبأ الأمر بسيط جدا  وسأشرح لك خطوة بخطوة كيف تضيف شرطا جديدا  (مثل: موقع التحميل في العمود k) إلى الكود  بحيث يمكنك لاحقا تعديل أو إضافة أي شرط بنفس الطريقة

1) التحقق من أن العمود الجديد (k) ليس فارغا 
If Trim(WS.Cells(i, "M").Text) <> "" And _ Trim(WS.Cells(i, "L").Text) <> "" And _ Trim(WS.Cells(i, "K").Text) <> "" And _ <===== (موقع التحميل) العمود الجديد 2)  تعديل المفتاح M  ليشمل القيمة الجديدة  
m = Trim(WS.Cells(i, "M").Text) & "|" & Trim(WS.Cells(i, "L").Text) & "|" & Trim(WS.Cells(i, "K").Text) 3) تعديل إخراج البيانات المفككة من المفتاح
f = Split(k, "|") a = d(k) dest.Cells(r, 1).Resize(1, 7).Value = Array(f(0), f(1), f(2), a(0), a(1), a(2), a(3)) 4) لا تنسى تعديل رؤوس الأعمدة في الصف الأول لتتناسب مع التغيير 
dest.Range("A1").Resize(1, 7).Value _ = Array("الشهر", "اسم الشركة", "الموقع", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)") ليكون الكود النهائي بعد إظافة عمود موقع التحميل على الشكل التالي 
Option Explicit Sub TEST2() Dim dest As Worksheet, WS As Worksheet Dim m As String, a As Variant, k As Variant, f As Variant Dim d As Object: Set d = CreateObject("Scripting.Dictionary") Dim ShArr As Variant: ShArr = Array("aaa", "bbb") Dim i As Long, lr As Long, r As Long: r = 2 With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual On Error Resume Next Set dest = Sheets("تقرير مفصل") If dest Is Nothing Then Set dest = Sheets.Add dest.Name = "تقرير مفصل" Else With dest.Range("A:G") .ClearContents .Borders.LineStyle = xlNone End With End If On Error GoTo 0 dest.Range("A1").Resize(1, 7).Value _ = Array("الشهر", "اسم الشركة", "الموقع", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)") For Each WS In Sheets(ShArr) If WS.AutoFilterMode Then WS.AutoFilterMode = False lr = WS.Cells(WS.Rows.Count, "M").End(xlUp).Row For i = 2 To lr If Trim(WS.Cells(i, "M").Text) <> "" And Trim(WS.Cells(i, "L").Text) <> "" And Trim(WS.Cells(i, "K").Text) <> "" Then m = Trim(WS.Cells(i, "M").Text) & "|" & Trim(WS.Cells(i, "L").Text) & "|" & Trim(WS.Cells(i, "K").Text) If Not d.exists(m) Then d(m) = Array(0, 0, 0, 0) d(m) = Array(d(m)(0) + 1, d(m)(1) + tmp(WS.Cells(i, "S").Value), d(m)(2) + tmp(WS.Cells(i, "U").Value), d(m)(3) + tmp(WS.Cells(i, "F").Value)) End If Next i Next WS For Each k In d.Keys f = Split(k, "|") a = d(k) dest.Cells(r, 1).Resize(1, 7).Value = Array(f(0), f(1), f(2), a(0), a(1), a(2), a(3)) r = r + 1 Next k Call ShFormat(dest, "A:G") .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic End With MsgBox "تم إعداد التقرير المفصل بنجاح", vbInformation End Sub "======================================= Private Function tmp(x As Variant) As Double tmp = IIf(IsNumeric(x), x, 0) End Function '======================================= Private Sub ShFormat(ByRef WS As Worksheet, ByVal Col As String) With WS .Activate Dim lastRow As Long lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row With WS.Range("A1:G" & lastRow).Borders .LineStyle = xlDash: .Weight = xlThin: .ColorIndex = xlAutomatic End With .DisplayRightToLeft = True .Columns(Col).EntireColumn.AutoFit .Columns(Col).HorizontalAlignment = xlCenter .Columns(Col).VerticalAlignment = xlBottom .Range("E:G").NumberFormat = "0" End With End Sub ملاحظة : يمكنك تعطيل تنسيق الجدول النهائي بحذف أو تعليق هذا السطر  أو تعديله ليشمل أعمدة أكثر إذا زادت الأعمدة لاحقا
Call ShFormat(dest, "A:G")  
تقرير - حسب - الشهر - والشركة -الموقعV2 .xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 
جرب هدا 
Sub test() Dim dest As Worksheet, WS As Worksheet Dim m As String, a As Variant, k As Variant Dim d As Object: Set d = CreateObject("Scripting.Dictionary") Dim ShArr As Variant: ShArr = Array("aaa", "bbb") Dim i As Long, lr As Long, r As Long: r = 2 With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual On Error Resume Next Set dest = Sheets("التقرير") If dest Is Nothing Then Set dest = Sheets.Add: dest.Name = "التقرير" Else dest.Range("A:E").ClearContents On Error GoTo 0 dest.Range("A1").Resize(1, 5).Value _ = Array("الشهر", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)") For Each WS In Sheets(ShArr) lr = WS.Cells(WS.Rows.Count, "M").End(xlUp).Row For i = 2 To lr m = Trim(WS.Cells(i, "M").Text) If m <> "" Then If Not d.exists(m) Then d(m) = Array(0, 0, 0, 0) a = d(m) a(0) = a(0) + 1: a(1) = a(1) + tmp(WS.Cells(i, "S").Value) a(2) = a(2) + tmp(WS.Cells(i, "U").Value): a(3) = a(3) + tmp(WS.Cells(i, "F").Value) d(m) = a End If Next i Next WS For Each k In d.Keys a = d(k) dest.Cells(r, 1).Resize(1, 5).Value = Array(k, a(0), a(1), a(2), a(3)) r = r + 1 Next k .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic End With MsgBox "تم إعداد التقرير بنجاح", vbInformation End Sub Private Function tmp(x As Variant) As Double tmp = IIf(IsNumeric(x), x, 0) End Function  
تقرير من شيتين v2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 
هل ترغب بإستخدام الأكواد ؟
ادا كان هدا يناسبك ضع هدا في حدث الورقة 
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Cell As Range, tmp As Long On Error GoTo CleanExit Application.EnableEvents = False If Not Intersect(Target, Me.Range("A2:A" & Me.Rows.Count)) Is Nothing Then For Each Cell In Intersect(Target, Me.Range("A2:A" & Me.Rows.Count)) If Trim(Cell.Value) <> "" Then tmp = Application.WorksheetFunction.CountIf(Me.Range("A:A"), Cell.Value) If tmp > 1 Then Cell.ClearContents End If End If Next Cell End If CleanExit: Application.EnableEvents = True End Sub  

وعليكم السلام ورحمة الله تعالى وبركاته 
ضع هدا في حدث ورقة معلمين
Option Explicit Private Const ShName As String = "معلمين" Private Sub Worksheet_Calculate() Static tmps As Boolean If tmps Then Exit Sub tmps = True If Not IsEmpty(Me.Range("D5").Value) Then Coloring_Classes tmps = False End Sub Sub Coloring_Classes() Dim Sh As Worksheet: Set Sh = ThisWorkbook.Sheets(ShName) On Error GoTo HandleError Application.ScreenUpdating = False: Application.EnableEvents = False Application.Calculation = xlCalculationManual xColor Sh, Sh.[D5].Value, "C7:I11" xColor Sh, Sh.[D18].Value, "C20:I24" xColor Sh, Sh.[D30].Value, "C32:I36" Cleanup: Application.ScreenUpdating = True: Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Exit Sub HandleError: Resume Cleanup End Sub Sub xColor(ws As Worksheet, Search As String, cnt As String) Dim xCell As Range, xRng As Long, OnRng As Range, ky As Variant Dim r As Long, c As Long, n() As Long Set OnRng = ws.Range(cnt) If Trim(Search) = "" Then: OnRng.Interior.ColorIndex = xlColorIndexNone: Exit Sub Set xCell = ws.Range("Q2:Q" & ws.Cells(ws.Rows.Count, "Q").End(xlUp).Row) _ .Find(What:=Search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False) If xCell Is Nothing Then: OnRng.Interior.ColorIndex = xlColorIndexNone: Exit Sub xRng = xCell.Offset(0, 1).Interior.Color ky = OnRng.Value ReDim n(1 To UBound(ky, 1), 1 To UBound(ky, 2)) For r = 1 To UBound(ky, 1) For c = 1 To UBound(ky, 2) If Not IsError(ky(r, c)) And Len(Trim(ky(r, c))) > 0 Then n(r, c) = xRng End If Next c Next r OnRng.Interior.ColorIndex = xlColorIndexNone For r = 1 To UBound(n, 1) For c = 1 To UBound(n, 2) If n(r, c) <> 0 Then OnRng.Cells(r, c).Interior.Color = n(r, c) End If Next c Next r End Sub  
 
 
جدول التفريغ V2.xlsm

نعم أخي يمكننا فعل دالك 

 
للتوضيح :

 
تم إظافة تحديث الإسم الكامل للموظف عند الإدخال مباشرة للمعاينة فقط لأنه في الأصل يحدث عند كل ترحيل أو تعديل للبيانات  
 
 
المرفقات 
https://www.mediafire.com/file/bq3nkauzlo9j3jt/بيانات+الموظفين+v2.rar/file
تم رفعه في المشاركه
 
قاعدة بيانات الموظفين 2 .xlsm
بيانات الموظفين v2.rar

من المفروض أولا كما سبق الدكر محاولة إلغاء دمج الخلايا لضمان أن الكود يتعامل مع كل خلية على حدة وحصولك على نتائج صحيحة  
جرب هدا هل يناسيك 
Option Explicit Public Sub Add_CheckBoxes() Dim tbl As Long, cb As OLEObject, OnRng As Range, ky As Variant Dim dataArray() As String, Search As String, n As Boolean Dim i As Long, lastRow As Long, col As Long, lastCol As Long Dim kys() As String Dim CrWS As Worksheet: Set CrWS = Sheets("MenuF") Dim dest As Worksheet: Set dest = Sheets("main sheet") Search = Trim(CrWS.Range("B1").Value) If Search = "" Then: MsgBox "يرجى إدخال قيمة البحث", vbExclamation: Exit Sub lastRow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row n = False For i = 2 To lastRow If Trim(dest.Cells(i, 1).Value) = Search Then tbl = i n = True Exit For End If Next i If Not n Then: MsgBox "قيمة البحث غير موجودة على قاعدة البيانات", vbExclamation: Exit Sub lastCol = dest.Cells(tbl, Columns.Count).End(xlToLeft).Column ReDim dataArray(1 To lastCol - 1) For col = 2 To lastCol dataArray(col - 1) = Trim(dest.Cells(tbl, col).Value) Next col For Each cb In CrWS.OLEObjects If TypeName(cb.Object) = "CheckBox" Then cb.Object.Value = False Next cb For Each OnRng In CrWS.Range("A3:I7") If OnRng.Value <> "" Then kys = Split(Replace(OnRng.Value, "،", ","), ",") For Each ky In kys For i = LBound(dataArray) To UBound(dataArray) If CompareValues(tmp(dataArray(i)), tmp(ky)) Then For Each cb In CrWS.OLEObjects If TypeName(cb.Object) = "CheckBox" Then If cb.TopLeftCell.Address = OnRng.Address Then cb.Object.Value = True Exit For End If End If Next cb End If Next i Next ky End If Next OnRng End Sub Private Function tmp(ByVal txt As String) As String tmp = Replace(Replace(Trim(txt), " ", " "), "ال", "") End Function Private Function CompareValues(val1 As String, val2 As String) As Boolean CompareValues = (InStr(1, val1, val2, vbTextCompare) > 0 Or InStr(1, val2, val1, vbTextCompare) > 0) End Function  لتلوين القيم 
CrWS.Range("A3:I7").Font.Color = vbBlack For Each OnRng In CrWS.Range("A3:I7") If OnRng.Value <> "" Then kys = Split(Replace(OnRng.Value, "?", ","), ",") For Each ky In kys For i = LBound(dataArray) To UBound(dataArray) If CompareValues(tmp(dataArray(i)), tmp(ky)) Then For Each cb In CrWS.OLEObjects If TypeName(cb.Object) = "CheckBox" Then If cb.TopLeftCell.Address = OnRng.Address Then cb.Object.Value = True Exit For End If End If Next cb OnRng.Font.Color = vbRed End If Next i Next ky  يمكنك إختيار ما يناسبك 

 
 
فورمة - V4.xlsb

نعم أخي @نبا زيد  يمكننا فعل دالك لاكن لدي إقتراح أعتقد أنه أفضل بدلا من تعديل الألوان مباشرة في الكود كل مرة يمكنك  تحديد ألوان الخلفية ولون الخط بسهولة من داخل ورقة تمت إظافتها للملف بإسم  الإعدادات كما هو موضح في الصورة التالية 

 
كل ما عليك فعله هو
1) تحديد اسم الحالة في العمود A  مثل 
غائب - متأخر  - مجاز - عطلة - حاضر - نهاية الأسبوع
2) اختيار اللون المناسب للخلفية في العمود B
3) اختيار اللون المناسب للخط في العمود C
كل حالة سيتم تلوينها تلقائيا بناء على الألوان التي تحددها في ورقة الإعدادات مما يتيح لك تعديل الألوان في أي وقت بما يتناسب مع احتياجاتك دون التأثير على الكود

أتمنى أن تجد هذه الفكرة مفيدة 
بالتوفيق 
Option Explicit Sub Remplissez() On Error GoTo SupApp Const FontName As String = "Arial" Const StartCol As Long = 5, TimeCol As Long = 4, NamArr As Long = 2 Const StartRow As Long = 7, LastCol As Long = 34 Dim xTime As String, Snt As String, Key As String, Icon As String Dim tmp As Object, tbl As Object, xColor As Object, xFont As Object Dim xAbsen As String, xName As String, DayName As String, Status As String Dim LastRow As Long, i As Long, col As Long, r As Long, n As Long, xDate As Date Dim f As Boolean, sWeekend As Boolean, a As Variant, b As Variant, c As Variant, j As Range Dim dest As Worksheet: Set dest = Sheets("الاستمارة") Dim CrWS As Worksheet: Set CrWS = Sheets("التواريخ") Dim WsSet As Worksheet: Set WsSet = Sheets("الإعدادات") Icon = ChrW(&H2714): xAbsen = ChrW(&H274C) Set tmp = CreateObject("Scripting.Dictionary") Set tbl = CreateObject("Scripting.Dictionary") Set xColor = CreateObject("Scripting.Dictionary") Set xFont = CreateObject("Scripting.Dictionary") For r = 2 To WsSet.Cells(WsSet.Rows.Count, "A").End(xlUp).Row Dim OnRng As String: OnRng = Trim(WsSet.Cells(r, 1).Value) If OnRng <> "" Then xColor(OnRng) = WsSet.Cells(r, 2).Interior.Color xFont(OnRng) = WsSet.Cells(r, 3).Interior.Color End If Next r SetApp False For r = 4 To CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row If Trim(CrWS.Cells(r, 3).Value) = "عطلة" Then tmp(CLng(CrWS.Cells(r, 1).Value)) = True Next r For r = 4 To CrWS.Cells(CrWS.Rows.Count, "E").End(xlUp).Row If CrWS.Cells(r, 5).Value <> "" And IsDate(CrWS.Cells(r, 6).Value) Then xName = Trim(CrWS.Cells(r, 5).Value) xDate = CrWS.Cells(r, 6).Value xTime = Trim(CrWS.Cells(r, 9).Value) Status = Trim(CrWS.Cells(r, 7).Value) Key = xName & "|" & CLng(xDate) & "|" & xTime tbl(Key) = Status If xTime = "صباحي/مسائي" Then tbl(xName & "|" & CLng(xDate) & "|صباحي") = Status tbl(xName & "|" & CLng(xDate) & "|مسائي") = Status End If End If Next r LastRow = dest.Cells(dest.Rows.Count, 4).End(xlUp).Row a = dest.Range(dest.Cells(StartRow, 1), dest.Cells(LastRow, LastCol)).Value b = dest.Range(dest.Cells(5, StartCol), dest.Cells(5, LastCol)).Value c = dest.Range(dest.Cells(6, StartCol), dest.Cells(6, LastCol)).Value For i = 1 To UBound(a, 1) If Trim(a(i, NamArr)) <> "" Then xName = Trim(a(i, NamArr)) For col = StartCol To LastCol n = col - StartCol + 1 If IsDate(b(1, n)) Then xDate = b(1, n): DayName = c(1, n): f = tmp.exists(CLng(xDate)) sWeekend = (DayName = "الجمعة" Or DayName = "السبت") xTime = Trim(a(i, TimeCol)) Key = xName & "|" & CLng(xDate) & "|" & xTime Status = IIf(tbl.exists(Key), tbl(Key), "") a(i, col) = IIf(f Or sWeekend Or Status = "غائب" Or _ Status = "مجاز" Or Status = "متأخر", xAbsen, Icon) End If Next col Next i dest.Range(dest.Cells(StartRow, 1), dest.Cells(LastRow, LastCol)).Value = a With dest.Range(dest.Cells(StartRow, StartCol), dest.Cells(LastRow, LastCol)) .Font.Name = FontName: .Font.Bold = True .Font.Color = vbBlack: .Interior.ColorIndex = xlNone For Each j In .Cells If j.Value = Icon Then If xColor.exists("حاضر") Then j.Interior.Color = xColor("حاضر") If xFont.exists("حاضر") Then j.Font.Color = xFont("حاضر") ElseIf j.Value = xAbsen Then Dim ColArr As Long: ColArr = j.Column - StartCol + 1 Dim RowArr As Long: RowArr = j.Row - StartRow + 1 xDate = b(1, ColArr) If Trim(a(RowArr, NamArr)) <> "" Then xName = Trim(a(RowArr, NamArr)) xTime = Trim(a(RowArr, TimeCol)) Key = xName & "|" & CLng(xDate) & "|" & xTime Status = IIf(tbl.exists(Key), tbl(Key), "") Snt = IIf(tmp.exists(CLng(xDate)), "عطلة", IIf(c(1, ColArr) = "الجمعة" Or _ c(1, ColArr) = "السبت", "نهاية الأسبوع", Status)) If xColor.exists(Snt) Then j.Interior.Color = xColor(Snt) If xFont.exists(Snt) Then j.Font.Color = xFont(Snt) End If Next j End With ExitSub: SetApp True MsgBox "تم تحديث البيانات بنجاح", vbInformation Exit Sub SupApp: Resume ExitSub 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  
 
استمارة-بعض النتائج المطلوبة v3.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته 
هذا يتطلب ببساطة تحديد حجم ثابت للدوائر  بدلا من حسابه بناء على حجم الخلايا
يمكنك تغيير هذه القيمة حسب الحجم الذي ترغب فيه   tmp = 10 
Option Explicit Sub DrawCircles() Const SROW As Long = 6, EROW As Long = 10, SCOL As Long = 2, ECOL As Long = 9 Dim ws As Worksheet, sColName As String, i As Long, j As Long, n As Long, tmp As Double Application.ScreenUpdating = False Call DelShap Set ws = ActiveSheet tmp = 10 For i = SROW To EROW With ws n = .Range("k" & i).Value For j = ECOL To SCOL Step -1 If .Range(.Cells(i, j).Address).Value <> Empty And n > 0 Then sColName = Split(.Cells(1, j).Address, "$")(1) With ActiveSheet.Shapes.AddShape(msoShapeOval, _ .Range(sColName & i).Left + 0.5 * (.Range(sColName & i).Width - 2 * tmp), _ .Range(sColName & i).Top + 0.5 * (.Range(sColName & i).Height - 2 * tmp), _ 2 * tmp, 2 * tmp) .Line.Weight = 2 .Line.ForeColor.RGB = RGB(10, 10, 10) .Fill.Visible = msoFalse End With n = n - 1 End If If n = 0 Then Exit For Next j End With Next i Application.ScreenUpdating = True End Sub
   

 

هذا الكود سيحذف جميع الصفوف التي تحتوي على قيم غير فريدة في العمود المحدد
بمعنى سيتم حذف جميع الصفوف التي تحتوي على قيم متكررة، بما في ذلك النسخة الأولى لكل قيمة
Sub RemoveAllDuplicates() Dim f As Worksheet Dim Irow As Long, i As Long Dim dict As Object, tmp As Variant Dim uniqueDict As Object Dim n As Long Dim Col As String: Col = "A" Dim startRow As Long: startRow = 2 Set f = ThisWorkbook.Sheets("Sheet1") Irow = f.Cells(f.Rows.Count, Col).End(xlUp).Row Set dict = CreateObject("Scripting.Dictionary") Set uniqueDict = CreateObject("Scripting.Dictionary") n = 0 For i = startRow To Irow tmp = f.Cells(i, Col).Value If tmp <> "" Then If dict.exists(tmp) Then dict(tmp) = dict(tmp) + 1 Else dict.Add tmp, 1 End If End If Next i For i = Irow To startRow Step -1 tmp = f.Cells(i, Col).Value If tmp <> "" Then If dict(tmp) > 1 Then f.Rows(i).Delete n = n + 1 ElseIf dict(tmp) = 1 And uniqueDict.exists(tmp) Then f.Rows(i).Delete n = n + 1 Else uniqueDict.Add tmp, True End If End If Next i If n > 0 Then MsgBox "تم حذف جميع التكرارات" & vbCrLf & _ vbCrLf & "عدد الصفوف المحذوفة: " & n, vbInformation Else MsgBox "لم يتم العثور على أي تكرارات", vbInformation End If End Sub  
 
Supprimer_les_doublon.xlsb

تفضل جرب هدا  
Option Explicit Sub Convert_Arabic() Dim WS As Worksheet, OnRng As Range, ky As Range Dim i As Integer, j As Integer, NumArr As Variant, tmp As Variant Dim val As String, c As String, newVal As String, n As Boolean NumArr = Array(ChrW(1632), ChrW(1633), ChrW(1634), ChrW(1635), _ ChrW(1636), ChrW(1637), ChrW(1638), ChrW(1639), ChrW(1640), ChrW(1641)) tmp = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9") Set WS = Sheets("Sheet1") Set OnRng = WS.UsedRange Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.ErrorCheckingOptions.BackgroundChecking = False For Each ky In OnRng If Not IsEmpty(ky.Value) And Not ky.HasFormula Then val = Trim(ky.Text): newVal = "": n = False If val Like "*[" & Join(NumArr, "") & "]*" Then GoTo SubApp If Right(val, 1) = "%" Then n = True: val = Left(val, Len(val) - 1) For i = 1 To Len(val) c = Mid(val, i, 1) If c Like "[0-9]" Then newVal = newVal & NumArr(CInt(c)) Else newVal = newVal & c End If Next i If n Then newVal = newVal & "%" ky.NumberFormat = "@": ky.Value = newVal End If SubApp: Next ky Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub أو يمكنك التنقل بينها على الشكل التالي 

 
تحويل الورقة بالكامل الى لغة عربية دون تغير لغة الجهاز -v2 .xlsb

تفضل جرب هدا 
لقد قمت بحدف مربعات النصوص  الخاصة بعنوان المدرسة والسنة الدراسية وتعويضها بتنسيق الخلايا مباشرة يمكنك تعديلها بما يناسبك 
Option Explicit Const tmp As Long = 45 ' <======= ' إرتفاع صف إسم المدرسة Private Const CrWS As String = "النتيجة أ" Private Const sFolder As String = "نتائج التلاميد" ' <=======' إسم مجلد حفظ النتائج Private Const NamePDF As String = "النتائج" ' <=======' PDF إسم الملف المستخرج Private Const Password As String = "119900" ' <======= ' باسوورد الأوراق الخاص بك Sub Copy_SavePDF() On Error GoTo SupError Dim WS As Worksheet, f As Worksheet, Data As Worksheet, OnRng As Range, rng As Range, myRng As Range Dim sPath As String, tempFile As String, arr As Variant, r As Range, Cpt As Long Dim lastRow As Long, i As Long, j As Long, début As Integer, fin As Integer Set f = Sheets(CrWS): Set Data = Sheets("قوائم شهرية أ") If f Is Nothing Or Data Is Nothing Then Exit Sub SetApp False f.Unprotect Password: Data.Unprotect Password f.[A4].Value = 1 Set myRng = Data.Range("C7", Data.Range("C" & Data.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeFormulas, 2) f.[A3].Value = myRng.Cells(myRng.Rows.Count, 1).Offset(0, -2).Value début = f.[A4].Value: fin = f.[A3].Value If Not IsNumeric(f.[A4].Value) Or Not IsNumeric(f.[A3].Value) Or début < 1 Or fin < 1 Or début > fin Then GoTo EndSub If MsgBox("هل ترغب بحفظ النتائج من " & début & " إلى " & fin & "؟", vbYesNo + vbExclamation, "تأكيد") = vbNo Then GoTo EndSub Set OnRng = f.Range("B7:P35") On Error Resume Next Set WS = Sheets("PDF") On Error GoTo SupError If WS Is Nothing Then Set WS = Sheets.Add: WS.Name = "PDF": WS.DisplayRightToLeft = True tempFile = ThisWorkbook.Path & "\" & sFolder If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile For i = début To fin Step 2 f.[A4].Value = i lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row Set rng = WS.Range("B" & IIf(IsEmpty(WS.[B3].Value), lastRow + 1, lastRow + 5)) OnRng.Copy With rng .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths End With WS.HPageBreaks.Add Before:=WS.Cells(rng.Row + OnRng.Rows.Count, 1) Application.CutCopyMode = False Cpt = rng.Row Do While Cpt <= rng.Row + OnRng.Rows.Count - 1 If Not IsEmpty(WS.Cells(Cpt, 2).Value) Then WS.Rows(Cpt).rowHeight = tmp End If Cpt = Cpt + 15 Loop Next i lastRow = WS.Range("B:P").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set r = WS.Range("B1:P" & lastRow) arr = r.Value For i = 1 To UBound(arr, 1) For j = 1 To UBound(arr, 2) If arr(i, j) = 0 Then arr(i, j) = "" Next j Next i r.Value = arr For i = 4 To lastRow If Trim(WS.Cells(i, 2).Value) = "اسم التلميذ/" And _ (WS.Cells(i, 14).Value = "" Or Not IsNumeric(WS.Cells(i, 14).Value)) Then WS.Rows(i).Hidden = True If i + 1 <= lastRow Then WS.Rows(i + 1).Hidden = True: If i - 1 >= 4 Then WS.Rows(i - 1).Hidden = True For j = i + 2 To lastRow WS.Rows(j).Hidden = True Next j Exit For End If Next i sPath = tempFile & "\" & NamePDF & ".pdf" With WS.PageSetup lastRow = WS.Range("B:P").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row .Orientation = xlPortrait: .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False .TopMargin = Application.InchesToPoints(0.5): .BottomMargin = Application.InchesToPoints(0.5) .LeftMargin = Application.InchesToPoints(0.2): .RightMargin = Application.InchesToPoints(0.2) .CenterHorizontally = True: .PrintArea = "B1:P" & lastRow End With WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False f.[A4].Value = 1: WS.Delete MsgBox "تم حفظ جميع نتائج الطلاب بنجاح", vbInformation EndSub: f.Protect Password: Data.Protect Password SetApp True Exit Sub SupError: Resume EndSub End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next Application.ScreenUpdating = enable Application.EnableEvents = enable Application.DisplayAlerts = enable End Sub  
 
النتائج.pdf كنترول-صف-سادس-أ-ب سجل وسطي v2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته
يجب أولا التأكد من عدم تعطيل وحدات الماكرو بسبب أمان الملفات
 أغلق الملف ثم انقر بزر الماوس الأيمن على  خصائص <------ إلغاء الحظر (Unblock)
أعد فتح الملف وحاول تشغيل الماكرو التالي 

Sub OECUE1() Dim WS As Worksheet Dim début As Integer, fin As Integer Set WS = Sheets("haneen") If Not IsNumeric(WS.[H2].Value) Or Not IsNumeric(WS.[U2].Value) Then Exit Sub début = WS.[H2].Value: fin = WS.[U2].Value If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب في تنفيذ الطباعة؟", vbYesNo + vbExclamation, "التأكيد") = vbNo Then Exit Sub Application.ScreenUpdating = False Do While début <= fin WS.PrintOut Copies:=1, Collate:=True If début < fin Then WS.[H2].Value = début + 1 début = début + 1 Loop Application.ScreenUpdating = True End Sub  
الطباعة.rar

Dim Sh As Boolean Public Property Get f() As Worksheet Set f = Sheets("Sheet1") <========= إسم ورقة العمل المرغوب جلب إسم المصنف الجديد منها End Property Private Sub UserForm_Initialize() Dim WS As Worksheet, CrWS As Variant, i As Integer ' قم بتعديل أسماء أوراق العمل المرغوب إظهارها CrWS = Array("Sheet1", "Sheet2", "Sheet3") For Each WS In ThisWorkbook.Worksheets For i = LBound(CrWS) To UBound(CrWS) If WS.name = CrWS(i) Then ListBox1.AddItem WS.name Exit For End If Next i Next WS HideBar Me End Sub Private Sub CommandButton1_Click() Dim i As Integer, ShName As String, newWb As Workbook, sPath As String Dim tmps As Integer, shArr As String, sCount As Integer, WBname As String WBname = f.[R2].Value <======= قم بتعديل عنوان خلية الإسم بما يناسبك If WBname = "" Then: MsgBox "الرجاء إدخال إسم المصنف ", vbExclamation, "إنتباه": Exit Sub 'Code........ .............. End Sub  

 
Private Sub CommandButton2_Click() On Error GoTo SupApp Dim arr As New Collection, TempWb As Workbook, WS As Worksheet Dim i As Integer, sMsg As Integer, tbl As Boolean Dim WBname As String, sPath As String, shArr As String WBname = Trim(f.Range("R2").Value) If WBname = "" Then MsgBox "الرجاء إدخال اسم المصنف", vbExclamation, "تنبيه": Exit Sub tbl = Me.CheckBox1.Value For i = 0 To Me.ListBox1.ListCount - 1 If tbl Or Me.ListBox1.Selected(i) Then arr.Add Me.ListBox1.List(i) shArr = shArr & Me.ListBox1.List(i) & "- " sMsg = sMsg + 1 End If Next If sMsg = 0 Then MsgBox "الرجاء تحديد ورقة عمل واحدة على الأقل", vbExclamation, "تنبيه": Exit Sub If Len(shArr) > 0 Then shArr = Left(shArr, Len(shArr) - 2) End If If MsgBox("هل أنت متأكد أنك تريد حفظ الأوراق التالية؟" & _ vbNewLine & vbNewLine & shArr, vbYesNo + vbQuestion, "PDF" & " تأكيد الحفظ") = vbNo Then Exit Sub With Application .ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False: .Calculation = xlCalculationManual End With Set TempWb = Workbooks.Add(xlWBATWorksheet) For i = 1 To arr.Count ThisWorkbook.Sheets(arr(i)).Copy After:=TempWb.Sheets(TempWb.Sheets.Count) Next sPath = ThisWorkbook.path & "\" & WBname & ".pdf" If Dir(sPath) <> "" Then Kill sPath TempWb.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False TempWb.Close False MsgBox "تم حفظ الملفات بنجاح", vbInformation, "PDF حفظ" Unload Me CleanUp: With Application .ScreenUpdating = True: .EnableEvents = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic End With Exit Sub SupApp: On Error Resume Next: If Not TempWb Is Nothing Then TempWb.Close False Resume CleanUp End Sub  
 
تصدير صفحات v3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 
إدن لنجرب هدا
الخلية N6 
="الالتزام "&INDEX({"الأول","الثاني","الثالث","الرابع","الخامس","السادس"}, ROW(A1)) الخلية L6 
=IFERROR(INDEX($E$8:$E$367, MATCH(0, COUNTIF($L$5:L5, $E$8:$E$367), 0)), 0) الخلية K6
 
=IF(L6=0, 0, IF(L6<>"", COUNTIFS($E$8:$E$367, L6, $E$8:$E$367, "<>"), "0")) مع سحب المعادلات للأسفل 

 
 
 
Book2-V3.xlsx

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

 
Function NumtoTxt(TheNo As Double, MyCur As String, MySubCur As String) As String Dim txtArr1(0 To 9) As String, txtArr2(0 To 9) As String, txtArr3(0 To 9) As String Dim Myno As String, GetNo As String, RdNo As String, My100 As String, I As Integer Dim My10 As String, My1 As String, My11 As String, My12 As String, GetTxt As String Dim MyAnd As String, Mybillion As String, MyMillion As String, MyThou As String Dim MyHun As String, MyFraction As String, ReMark As String If TheNo > 999999999999.999 Then Exit Function If TheNo < 0 Then TheNo = TheNo * -1: ReMark = "يتبقى لكم " Else ReMark = "" If TheNo = 0 Then NumtoTxt = "صفر": Exit Function MyAnd = " و" txtArr1(0) = "": txtArr1(1) = "مائة": txtArr1(2) = "مائتان": txtArr1(3) = "ثلاثمائة": txtArr1(4) = "أربعمائة" txtArr1(5) = "خمسمائة": txtArr1(6) = "ستمائة": txtArr1(7) = "سبعمائة": txtArr1(8) = "ثمانمائة": txtArr1(9) = "تسعمائة" txtArr2(0) = "": txtArr2(1) = "عشر": txtArr2(2) = "عشرون": txtArr2(3) = "ثلاثون": txtArr2(4) = "أربعون" txtArr2(5) = "خمسون": txtArr2(6) = "ستون": txtArr2(7) = "سبعون": txtArr2(8) = "ثمانون": txtArr2(9) = "تسعون" txtArr3(0) = "": txtArr3(1) = "واحد": txtArr3(2) = "اثنان": txtArr3(3) = "ثلاثة": txtArr3(4) = "أربعة" txtArr3(5) = "خمسة": txtArr3(6) = "ستة": txtArr3(7) = "سبعة": txtArr3(8) = "ثمانية": txtArr3(9) = "تسعة" GetNo = Format(TheNo, "000000000000.000") I = 0 Do While I < 15 If I < 12 Then Myno = Mid$(GetNo, I + 1, 3) ElseIf I = 12 Then Myno = Mid$(GetNo, I + 2, 3) End If If Val(Myno) > 0 Then RdNo = Mid$(Myno, 1, 1): My100 = txtArr1(Val(RdNo)) RdNo = Mid$(Myno, 3, 1): My1 = txtArr3(Val(RdNo)) RdNo = Mid$(Myno, 2, 1): My10 = txtArr2(Val(RdNo)) If Mid$(Myno, 2, 2) = "11" Then My11 = "إحدى عشر" If Mid$(Myno, 2, 2) = "12" Then My12 = "اثنا عشر" If Mid$(Myno, 2, 2) = "10" Then My10 = "عشرة" If Val(Mid$(Myno, 1, 1)) > 0 And Val(Mid$(Myno, 2, 2)) > 0 Then My100 = My100 + MyAnd If Val(Mid$(Myno, 3, 1)) > 0 And Val(Mid$(Myno, 2, 1)) > 1 Then My1 = My1 + MyAnd GetTxt = My100 + My1 + My10 If Val(Mid$(Myno, 3, 1)) = 1 And Val(Mid$(Myno, 2, 1)) = 1 Then GetTxt = My100 + My11: If Val(Mid$(Myno, 1, 1)) = 0 Then GetTxt = My11 End If If Val(Mid$(Myno, 3, 1)) = 2 And Val(Mid$(Myno, 2, 1)) = 1 Then GetTxt = My100 + My12: If Val(Mid$(Myno, 1, 1)) = 0 Then GetTxt = My12 End If If I = 0 And GetTxt <> "" Then If Val(Myno) > 10 Then Mybillion = GetTxt + " مليار" Else Mybillion = GetTxt + " مليارات" If Val(Myno) = 1 Then Mybillion = "مليار" If Val(Myno) = 2 Then Mybillion = "ملياران" End If If I = 3 And GetTxt <> "" Then If Val(Myno) > 10 Then MyMillion = GetTxt + " مليون" Else MyMillion = GetTxt + " ملايين" If Val(Myno) = 1 Then MyMillion = "مليون" If Val(Myno) = 2 Then MyMillion = "مليونان" End If If I = 6 And GetTxt <> "" Then If Val(Myno) > 10 Then MyThou = GetTxt + " ألف" Else MyThou = GetTxt + " آلاف" If Val(Mid$(Myno, 3, 1)) = 1 Then MyThou = "ألف" If Val(Mid$(Myno, 3, 1)) = 2 Then MyThou = "ألفان" End If If I = 9 And GetTxt <> "" Then MyHun = GetTxt If I = 12 And GetTxt <> "" Then MyFraction = GetTxt End If I = I + 3 Loop If Mybillion <> "" Then If MyMillion <> "" Or MyThou <> "" Or MyHun <> "" Then Mybillion = Mybillion + MyAnd If MyMillion <> "" Then If MyThou <> "" Or MyHun <> "" Then MyMillion = MyMillion + MyAnd If MyThou <> "" Then If MyHun <> "" Then MyThou = MyThou + MyAnd If MyFraction <> "" Then If Mybillion <> "" Or MyMillion <> "" Or MyThou <> "" Or MyHun <> "" Then NumtoTxt = ReMark & Mybillion & MyMillion & MyThou & MyHun & " " & MyCur & MyAnd & MyFraction & " " & MySubCur Else NumtoTxt = ReMark & MyFraction & " " & MySubCur End If Else NumtoTxt = ReMark & Mybillion & MyMillion & MyThou & MyHun & " " & MyCur End If End Function  
تعديل المبلغ - فلس V2.xlsm

لقد تم الإعتماد مسبقا على الكود الأول والدي كان يتضمن وضع الفواصل بعد كلمة Sum
تفضل أخي تم تعديل الكود ليتناسب مع طلبك 

لحفظ الصفحات في مجلد في نفس مسار المصنف بصيغة PDF جرب هدا 
Option Explicit Sub Save_PDF() On Error GoTo SupApp Dim WS As Worksheet, sPath As String, sFolder As String Dim count As Long, lastRow As Long, cell As Range, début As Integer Set WS = Sheets("test") lastRow = WS.Cells(WS.Rows.count, "B").End(xlUp).Row début = 1: count = 0 For Each cell In WS.Range("B2:B" & lastRow) If InStr(cell.Value, "المجموع") > 0 Then count = count + 1 Next cell If count > 0 Then If MsgBox("هل ترغب بحفظ الصفحات من " & début & " إلى " & count & "؟", _ vbYesNo + vbExclamation, "تأكيد") = vbNo Then Exit Sub sFolder = ThisWorkbook.Path & "\ملفات PDF" If Dir(sFolder, vbDirectory) = "" Then MkDir sFolder sPath = sFolder & "\" & "Page_" & début & "-" & count & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False MsgBox "تم حفظ الملف بنجاح", vbInformation End If SupApp: Set WS = Nothing End Sub  
 
 
تحديد عدد صفوف للصفحة ومجموعها -v3.xlsm للتنفيد على مصنف خارجي.rar Test PDF.pdf

وعليكم السلام ورحمة الله تعالى وبركاته 
Option Explicit Sub ResetColumns() Dim lr&, i& Dim WS As Worksheet: Set WS = ActiveSheet lr = 15 'WS.Columns("A:B").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For i = 3 To lr WS.Range(WS.Cells(i, 1), WS.Cells(i, 2)).Value = 0 Next i End Sub  
1919.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 
في Module
Option Explicit Sub Filtre() Dim tbl() As Variant, rng As Variant Dim desWS As Worksheet, WS As Worksheet Dim i As Long, j As Long, tmp As Long Set WS = Sheets("ورقة2") Set desWS = Sheets("ورقة1") Application.ScreenUpdating = False desWS.Range("A2:D" & desWS.Rows.Count).ClearContents rng = WS.Range("A2:D" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Value ReDim tbl(1 To UBound(rng), 1 To UBound(rng, 2)) For i = 1 To UBound(rng) If rng(i, 1) <> "" And rng(i, 4) > 0 Then tmp = tmp + 1 For j = 1 To UBound(rng, 2) tbl(tmp, j) = rng(i, j) Next j End If Next i If tmp > 0 Then desWS.Range("A2").Resize(tmp, UBound(tbl, 2)).Value = tbl Application.ScreenUpdating = True End Sub وفي حدث ورقة1
Private Sub Worksheet_Activate() Call Filtre End Sub  
مثال.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 
جرب هدا
Option Explicit Sub test() Dim ws As Worksheet: Set ws = Sheets("توزيع") Dim RowDest As Long: RowDest = 1 Dim Irow As Long, tmp As Long, ky As String Application.ScreenUpdating = False ws.Range("L1:L" & ws.Rows.Count).ClearContents For Irow = 7 To ws.Cells(ws.Rows.Count, "G").End(xlUp).Row ky = ws.Cells(Irow, "G").Value If ky <> "" Then tmp = IIf(ky = "آداب و فلسفة", 7, _ IIf(ky = "لغات أجنبية - إسبانية" Or ky = "لغات أجنبية - ألمانية", 8, 9)) For tmp = 1 To tmp ws.Cells(RowDest, 12).Value = ky & tmp RowDest = RowDest + 1 Next tmp End If Next Irow Application.ScreenUpdating = True End Sub  
Classeur2 v2.xlsm

تفضل أخي 
 
 
Private Const sFolder As String = "الكشوفات PDF" Private Const NamePDF As String = "كشف مناداة" Private Const CrWS As String = "لجان 4" Private Const Logo As String = "IMG" Sub Copy_SavePDFfinal() Dim WS As Worksheet, début As Integer, fin As Integer, i As Integer, row As Integer Dim sPath As String, tempFile As String, img As Shape, r As Shape Dim lastRow As Long, Rng As Range, OnRng As Range Dim f As Worksheet: Set f = Sheets(CrWS) If Not IsNumeric(f.[B1].Value) Or Not IsNumeric(f.[S2].Value) Then Exit Sub début = f.[B1].Value: fin = f.[S2].Value Set OnRng = f.Range("B2:O45") If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب بحفظ الصفحات من " & début & " إلى " & fin & "؟", _ vbYesNo + vbExclamation, "تأكيـــد") = vbNo Then Exit Sub Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Set WS = Sheets("PDF") If WS Is Nothing Then Sheets.Add.Name = "PDF" Set WS = Sheets("PDF") WS.DisplayRightToLeft = True End If On Error GoTo 0 tempFile = ThisWorkbook.Path & "\" & sFolder If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile For i = début To fin Step 2 f.[B1].Value = i lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).row If WS.Cells(2, 3).Value = "" Then Set Rng = WS.Range("B" & lastRow + 1) Else lastRow = WS.Range("C:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row Set Rng = WS.Range("B" & lastRow + 5) End If OnRng.Copy Rng.PasteSpecial Paste:=xlPasteValues Rng.PasteSpecial Paste:=xlPasteFormats Rng.PasteSpecial Paste:=xlPasteColumnWidths WS.Cells.NumberFormat = "0;-0;;@" On Error Resume Next Set img = f.Shapes(Logo) If Not img Is Nothing Then img.Copy WS.Paste Destination:=WS.Cells(Rng.row - 1, "F") Set img = WS.Shapes(Logo) img.Top = img.Top If img.Left + img.Width > WS.Range("O1").Left Then img.Left = WS.Range("O1").Left - img.Width End If If img.Top + img.Height > WS.Range("A:O").Rows(WS.Range("A:O").Rows.Count).Top Then img.Top = WS.Range("A:O").Rows(WS.Range("A:O").Rows.Count).Top - img.Height End If End If On Error GoTo 0 For row = 1 To OnRng.Rows.Count WS.Rows(Rng.row + row - 1).RowHeight = OnRng.Rows(row).RowHeight Next row WS.HPageBreaks.Add Before:=WS.Cells(Rng.row + OnRng.Rows.Count, 1) With WS.PageSetup .Orientation = xlPortrait: .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False .TopMargin = Application.InchesToPoints(0.5): .BottomMargin = Application.InchesToPoints(0.5) .LeftMargin = Application.InchesToPoints(0.2): .RightMargin = Application.InchesToPoints(0.2) .CenterHorizontally = True End With Application.CutCopyMode = False Next i sPath = tempFile & "\" & NamePDF & ".pdf" On Error Resume Next WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 f.[B1].Value = 1 WS.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح", vbInformation End Sub  
المصنف v3.xlsb

إدن لنجرب هدا
1) إظهار جميع القيم الموجودة بالعمود سواءا رقمية أو نصية وكدالك الفراغات بعد تمييزها بكلمة فارغة   
2) عند اختيار قيمة معينة من عنصر الكومبوبوكس سواءا نصية أو رقمية  سيتم حدف الصفوف التي تتضمن القيمة المحددة 
3) لجدف الصفوف الفارغة قم بتحديد  كلمة فارغة من عنصر كومبوبوكس 1
4) تمت إظافة دالة لترتيب القيم أبجديا على عنصر كومبوبوكس1 لتسهيل العثور على القيمة المطلوبة 
5) تم إظافة إعادة ترقيم البيانات على عمود A عند الحدف في حالة كنت بحاجة لدالك 
Private Sub UserForm_Initialize() Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long Set Tbl = CreateObject("Scripting.Dictionary") If Not CrWS Is Nothing Then lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow > 1 Then For Each c In CrWS.Range("B2:B" & lastRow) If Trim(c.Value) <> "" Then Tbl.Item(c.Value) = c.Value End If Next c End If If Application.WorksheetFunction.CountBlank(CrWS.Range("B2:B" & lastRow)) > 0 Then Tbl.Item("فارغة") = "فارغة" End If If Tbl.Count > 0 Then temp = Tbl.Items Call Tri(temp, LBound(temp), UBound(temp)) Me.ComboBox1.List = temp End If Else MsgBox "المصنف أو الورقة المحددة غير موجودة", vbExclamation End If End Sub Private Sub CommandButton1_Click() Dim lastRow As Long, ky As Variant, c As Range, OnRng As Range If Me.ComboBox1.Value <> "" Then If Not CrWS Is Nothing Then ky = Me.ComboBox1.Value lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then Exit Sub Application.ScreenUpdating = False If ky = "فارغة" Then For Each c In CrWS.Range("B2:B" & lastRow) If Trim(c.Value) = "" Then If OnRng Is Nothing Then Set OnRng = c.EntireRow Else Set OnRng = Union(OnRng, c.EntireRow) End If End If Next c Else For Each c In CrWS.Range("B2:B" & lastRow) If IsNumeric(c.Value) And IsNumeric(ky) Then If CDbl(c.Value) = CDbl(ky) Then If OnRng Is Nothing Then Set OnRng = c.EntireRow Else Set OnRng = Union(OnRng, c.EntireRow) End If End If Else If Trim(c.Value) = Trim(ky) Then If OnRng Is Nothing Then Set OnRng = c.EntireRow Else Set OnRng = Union(OnRng, c.EntireRow) End If End If End If Next c End If If Not OnRng Is Nothing Then OnRng.Delete End If With CrWS.Range("A2:A" & CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-1") End With UserForm_Initialize Me.ComboBox1.Value = "" Application.ScreenUpdating = True End If End If 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 3.rar

إدا كنت ترغب في إستخدام الإقتراح المقدم من الأستاد  @أبوعيد
يمكنك تجربة هدا 
Public Property Get CrWS() As Worksheet Set CrWS = Sheets("ورقة1") End Property Private Sub UserForm_Initialize() Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long Set Tbl = CreateObject("Scripting.Dictionary") lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow > 1 Then For Each c In CrWS.Range("B2:B" & lastRow) If c.Value <> "" Then Tbl.Item(c.Value) = c.Value Next c End If If Tbl.Count > 0 Then temp = Tbl.items Me.ComboBox1.List = temp End If End Sub Private Sub CommandButton1_Click() Dim lastRow As Long, ky As String If Me.ComboBox1.Value <> "" Then ky = "=*" & Me.ComboBox1.Value & "*" lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then Exit Sub Application.ScreenUpdating = False With CrWS.Range("B1:B" & lastRow) .AutoFilter Field:=1, Criteria1:=ky End With On Error Resume Next CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete On Error GoTo 0 CrWS.AutoFilterMode = False Application.ScreenUpdating = True Unload Me End If End Sub  
 
مسح صفوف معينة بناء على قيمتها v2.xlsb

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