محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك تعديل هدا بما يناسبك Option Explicit Sub Sauvegarde_WB() Dim WS As Worksheet, CrWS As Workbook, newWs As Worksheet, f As Worksheet Dim chemin$, sNom$, dossier$, sPath$, n As Boolean On Error GoTo EndClear SetApp False Set CrWS = Workbooks.Add(xlWBATWorksheet) Set f = CrWS.Sheets(1): f.Name = "Temp" n = True For Each WS In ThisWorkbook.Worksheets WS.Copy After:=CrWS.Sheets(CrWS.Sheets.Count) Set newWs = CrWS.Sheets(CrWS.Sheets.Count) newWs.UsedRange.Value = newWs.UsedRange.Value On Error Resume Next: newWs.Buttons(1).Delete: On Error GoTo 0 newWs.Name = Left(WS.Name, 31) If n Then: f.Delete: n = False Next WS dossier = ThisWorkbook.Path & "\Workbook_Copy" If Dir(dossier, vbDirectory) = "" Then MkDir dossier sPath = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) sNom = sPath & "_" & Format(Now, "dd-mm-yyyy") & ".xlsx" chemin = dossier & "\" & sNom CrWS.SaveAs Filename:=chemin, FileFormat:=xlOpenXMLWorkbook CrWS.Close False SetApp True Exit Sub EndClear: SetApp True End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub TEST.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد معاينة آخر مشاركاتك على المنتدى إليك الكود ليتوافق مع جميع الإصدارات سواءا 32bit أو 64bit جرب هدا ربما يناسبك Option Explicit #If VBA7 Then Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long #Else Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long #End If Private Const Style As Long = -16 Private Const Menu As Long = &H80000 Private Const MIN As Long = &H20000 Private Const MAX As Long = &H10000 Private Sub UserForm_Activate() Dim xForm As LongPtr, tmps As Long xForm = FindWindow("ThunderDFrame", Me.Caption) If xForm <> 0 Then tmps = GetWindowLong(xForm, Style) tmps = tmps Or Menu Or MIN Or MAX SetWindowLong xForm, Style, tmps DrawMenuBar xForm End If End Sub TEST Minimize.xlsb

أخي @algammal بما أننا اعتمدنا على العمل الديناميكي أثناء التعامل مع الملف أود أن أشاركك طريقة أخرى أكثر ديناميكية لإنشاء الأزرار الخاصة بالتنقل بين الأوراق دون الحاجة إلى نسخ الارتباطات من ورقة معاشات يتم إنشاء زر لكل ورقة عمل في المصنف بشكل تلقائي - استثناء الورقة التي يشير إليها الزر أي لا يضاف زر داخل نفس الورقة - تلوين الزر بنفس لون تبويب الورقة التي يشير إليها الزر لسهولة التعرف والتمييز البصري ربط الزر بكود التنقل GotoSheet الموضح أدناه مما يتيح الانتقال بين أوراق العمل المقصودة دون الإعتماد على أي إرتباط تشعبي Sub GotoSheet() SetApp False Dim wsName As String wsName = Replace(Application.Caller, "btn_", "") On Error Resume Next ThisWorkbook.Sheets(wsName).Activate On Error GoTo 0 SetApp True End Sub توحيد البحث في شيت واحد v10.xlsb

وعليكم السلام ورحمة الله وبركاته كان من الأفضل أخي @algammal فتح موضوع جديد لطلبك المتعلق بتعديل كود ترحيل البيانات أو على الأقل إدراج إستفسارك داخل الموضوع الأصلي المخصص لذلك وذلك أن الموضوع لم يغلق بعد ونحرص دوما على تجنب تداخل المواضيع حتى لا يحدث إرتباك أو لخبطة للقارئ لاحقا على العموم نترك هذا التقدير الكريم لإدارة المنتدى والمشرفين بالنسبة لملاحظتك حول إختفاء ألوان علامات التبويب والروابط التشعبية (Hyperlinks) بعد الضغط على زر ترحيل البيانات فالأمر ناتج ببساطة عن أن الكود يقوم بحذف الأوراق الموجودة مسبقا التي تم ترحيل البيانات لها ثم يعيد إنشاء أوراق جديدة بنفس الأسماء وبما أن الورقة تحذف تماما يتم معها حذف جميع التنسيقات والروابط التشعبية لأنها كانت مرتبطة بالورقة المحذوفة وليست بالاسم فقط نظرا للتغييرات الجديدة على الملف يمكنا تفادي هذه المشكلة بتعديل بسيط على الكود من خلال: بعد إنشاء كل ورقة جديدة بناء على إسم الوظيفة إعادة تلوين التبويب باستخدام شرط Select Case يمكنك طبعا إضافة مهن جديدة وتخصيص ألوانها بنفس الطريقة For Each f In dest.Keys Set tmp = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) tmp.Name = f: tmp.DisplayRightToLeft = True Select Case tmp.Name Case "طبيب": tmp.Tab.Color = RGB(128, 0, 128) Case "محامي": tmp.Tab.Color = RGB(101, 67, 33) Case "عامل": tmp.Tab.Color = RGB(255, 105, 180) ' يمكنك إضافة المزيد ' Case "مهندس": tmp.Tab.Color = RGB(...) End Select وكذلك نسخ الأشكال من ورقة معاشات للإحتفاظ بالإرتباط التشعبي مما يضمن إستمرار وظيفة التنقل بين الأوراق Dim Groupe As String: Groupe = "مجموعة 2" On Error Resume Next CrWS.Shapes(Groupe).Copy On Error GoTo 0 tmp.Range("C2").Select: tmp.Paste If tmp.Shapes.Count > 0 Then Set j = tmp.Shapes(tmp.Shapes.Count) CrWS.Range(harder).Copy: tmp.Range("A3").PasteSpecial xlPasteAll ليصبح الكود النهائي كما يلي : Sub TransferData() Const début As Long = 5, Height As Double = 20.25 Const départ As String = "A", Fin As String = "M" Const harder As String = "A3:M4" Dim Groupe As String: Groupe = "مجموعة 2" Dim CrWS As Worksheet, tmp As Worksheet, dest As Object Dim OnRng As Variant, i As Long, lastRow As Long, k As Variant, j As Shape Dim tbl As String, f As Variant, irow As Long, a() As Variant, n As Long, lr As Long On Error GoTo OnError Set CrWS = Sheets("معاشات"): Set dest = CreateObject("Scripting.Dictionary") lastRow = CrWS.Cells(CrWS.Rows.Count, départ).End(xlUp).Row If lastRow < début Then: MsgBox "لا توجد بيانات لترحيلها", vbExclamation: Exit Sub SetApp False OnRng = CrWS.Range(départ & début & ":" & Fin & lastRow).Value For i = 1 To UBound(OnRng, 1) tbl = Replace(Replace(Trim(OnRng(i, 5)), "/", "_"), "\", "_") If Len(tbl) > 0 Then dest(tbl) = Empty Next i For Each tmp In ThisWorkbook.Worksheets If Not tmp Is CrWS Then If dest.Exists(tmp.Name) Then On Error Resume Next: tmp.Delete: On Error GoTo OnError Next tmp For Each f In dest.Keys Set tmp = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) tmp.Name = f: tmp.DisplayRightToLeft = True Select Case tmp.Name Case "طبيب": tmp.Tab.Color = RGB(128, 0, 128) Case "محامي": tmp.Tab.Color = RGB(101, 67, 33) Case "عامل": tmp.Tab.Color = RGB(255, 105, 180) End Select On Error Resume Next CrWS.Shapes(Groupe).Copy On Error GoTo 0 tmp.Range("C2").Select: tmp.Paste If tmp.Shapes.Count > 0 Then Set j = tmp.Shapes(tmp.Shapes.Count) CrWS.Range(harder).Copy: tmp.Range("A3").PasteSpecial xlPasteAll Application.CutCopyMode = False ReDim a(1 To UBound(OnRng, 1), 1 To UBound(OnRng, 2)) n = 0 For irow = 1 To UBound(OnRng, 1) If Trim(OnRng(irow, 5)) = f Then n = n + 1 For i = 1 To UBound(OnRng, 2): a(n, i) = OnRng(irow, i) Next i End If Next irow If n > 0 Then tmp.Range("A5").Resize(n, UBound(OnRng, 2)).Value = a CrWS.Range("A5:M" & n + 4).Copy tmp.Range("A5").PasteSpecial xlPasteFormats Application.CutCopyMode = False End If CrWS.Columns("A:M").Copy tmp.Columns("A:M").PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False lr = tmp.Cells(tmp.Rows.Count, départ).End(xlUp).Row For i = 1 To lr: tmp.Rows(i).RowHeight = Height: Next i tmp.Rows(2).RowHeight = 24 k = Array("=COUNTIF($M$5:$M$" & lr & ", $B$3)", "=COUNTIF($F$5:$F$" & lr & ", $D$3)", _ "=COUNTIF($F$5:$F$" & lr & ", $G$3)") tmp.[C3].Formula = k(0): tmp.[E3].Formula = k(1): tmp.[H3].Formula = k(2) tmp.Range("A5:A" & lr).Formula = "=IF(B5<>"""",SUBTOTAL(3,$B$5:B5),"""")" tmp.[A4].Select Next f CrWS.Activate CleanUp: SetApp True MsgBox "تم ترحيل البيانات بنجاح", vbInformation Exit Sub OnError: Resume CleanUp End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub النتائج المتوقعة : توحيد البحث في شيت واحد v9.xlsb

لم تقم بدكر دالك ضمن المشاركة في مثالك الورقة تتضمن أسماء عناوين الأعمدة فقط تم تعديل المعادلة والكود في المشاركة السابقة لحساب مجموع العمود Adl. =SUMIFS(Data!$A$2:$A$1000, Data!$M$2:$M$1000, A2, Data!$O$2:$O$1000, B2, Data!$P$2:$P$1000, C2) أو =SUMIFS(Data!$A$2:$A$1000, Data!$M$2:$M$1000, A2, Data!$O$2:$O$1000, DATEVALUE(B2), Data!$P$2:$P$1000, C2) لحساب مجموع العمود Chd =SUMIFS(Data!$B$2:$B$1000, Data!$M$2:$M$1000, A2, Data!$O$2:$O$1000, B2, Data!$P$2:$P$1000, C2) اليك ملفين الأول بالمعادلات والثاني بالأكواد يمكنك إختيار ما يناسبك معادلة بدون تكرار v2-vba .xlsb معادلة بدون تكرار v2.xlsx

إليك أخي @algammal نسخة محدثة بعد تجربة الملف وظهور خطأ عند البحث بالرقم القومي لوحده توحيد البحث في شيت واحد v8.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته إدن لنجرب وضع المعادلة التالية في الخلية A2 ورقة TOTAL =LET( data, Data!M2:P1000, tour, INDEX(data,,1), date_, INDEX(data,,3), guide, INDEX(data,,4), keys, UNIQUE(FILTER(tour & "|" & guide & "|" & TEXT(date_, "dd/mm/yyyy"), (tour<>"")*(guide<>"")*(date_<>0))), rowNums, XMATCH(keys, tour & "|" & guide & "|" & TEXT(date_, "dd/mm/yyyy")), CHOOSE({1,2,3},INDEX(data, rowNums, 1), TEXT(INDEX(data, rowNums, 3), "dd/mm/yyyy"),INDEX(data, rowNums, 4) )) أو يمكنك إستخدام الكود التالي في Module Sub UpdateColArr() Const ColA = 1, ColB = 2, ColM = 13, ColO = 15, ColP = 16 Dim OnRng, dict As Object, a(), key As String Dim i As Long, tmps As Long Dim WS As Worksheet: Set WS = Sheets("Data") Dim dest As Worksheet: Set dest = Sheets("Total") Set dict = CreateObject("Scripting.Dictionary") SetApp False With dest .Range("A1:E" & .Rows.Count).ClearContents .Range("A1").Resize(1, 5).Value = [{"Tour Name","Tour Date","Guide Name","Adl.","Chd"}] With .Range("A1:E1").Borders: .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic: End With End With OnRng = WS.Range("A2:P" & WS.Cells(WS.Rows.Count, ColM).End(xlUp).Row).Value ReDim a(1 To UBound(OnRng), 1 To 5) For i = 1 To UBound(OnRng) If Trim(OnRng(i, ColM)) <> "" Then key = OnRng(i, ColM) & "|" & OnRng(i, ColO) & "|" & OnRng(i, ColP) If Not dict.exists(key) Then tmps = tmps + 1 a(tmps, 1) = OnRng(i, ColM): a(tmps, 2) = Format(OnRng(i, ColO), "dd/mm/yyyy") a(tmps, 3) = OnRng(i, ColP): a(tmps, 4) = Val(OnRng(i, ColA)): a(tmps, 5) = Val(OnRng(i, ColB)) dict.Add key, tmps Else Dim n As Long: n = dict(key) a(n, 4) = a(n, 4) + Val(OnRng(i, ColA)): a(n, 5) = a(n, 5) + Val(OnRng(i, ColB)) End If End If Next i If tmps > 0 Then dest.Range("A2").Resize(tmps, 5).Value = a SetApp True Set dict = Nothing: Set WS = Nothing: Set dest = Nothing End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With On Error GoTo 0 End Sub وفي حدث ورقة Sheet1 Private Sub Worksheet_Activate() On Error Resume Next: Call UpdateColArr: On Error GoTo 0 End Sub

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Public Property Get WS() As Worksheet: Set WS = Sheets("الاختلافات"): End Property Sub Button1_Click() Dim i As Long SetApp False For i = 3 To 62 WS.Rows(i).Hidden = (Application.WorksheetFunction.CountA(WS.Range("B" & i & ":R" & i)) = 0) Next i SetApp True End Sub Sub Button49_Click(): SetApp False: WS.Rows("3:62").Hidden = False: SetApp True: End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With On Error GoTo 0 End Sub كود إخفاء وإظهار.xlsb

الأخ الكريم @algammal و عليكم ورحمة الله وبركاته بارك الله فيك وجزاك خير الجزاء على كلماتك الطيبة ويكفيني فخرا أن يذكر اسمي بين قامات أفاضل أتعلم منهم كل يوم ما نحن إلا تلاميذ في هذا الصرح الطيب ننهل من علمكم ونستزيد من عطائكم وبمناسبة عيد الأضحى المبارك أتقدم بأطيب التهاني وأصدق الأمنيات لجميع الأعضاء والخبراء الكرام في المنتدى أسأل الله أن يتقبل طاعاتكم ويمن عليكم بالسعادة والعافية في الدارين وكل عام وأنتم ومن تحبون بخير وفضل ورضا

بخصوص استفساركم الكريم عن كيفية عمل الصورة المتحركة التي أرفقتها بالتعليق فالأمر ببساطة كالتالي قمت بتسجيل شاشة الجهاز باستخدام برنامج لتصوير الشاشة ثم قمت بحفظ الفيديو مباشرة بصيغة GIF وفي حالة استخدام برنامج لا يدعم هذه الصيغة يمكنك تسجيل الشاشة بصيغة فيديو عادية ثم تحويله لاحقا باستخدام أحد المواقع المجانية المتوفرة على الإنترنت بكل سهولة

أعتقد ان إستبدال هدا السطر سيوفي بالغرض من If xtbl > 0 Then Sh1.Range("A5").Resize(xtbl, 13).Value = Application.Index(v, Evaluate("ROW(1:" & xtbl & ")"), Evaluate("COLUMN(1:13)")) End If إلى If xtbl > 0 Then If xtbl = 1 Then Sh1.Range("A5").Resize(1, 13).Value = v Else Sh1.Range("A5").Resize(xtbl, 13).Value = v End If End If بطريقة مختلفة وأسرع نوعا ما Private Sub CommandButton1_Click() Dim i&, r&, c&, k&, t&, f&, xtbl&, lastRow&, n As Boolean, ok As Boolean, val$ Dim s, data, a(), ky(), tb(), j(), criteria() SetApp False ReDim ky(1 To MaxCombo): ReDim tb(1 To MaxCombo): ReDim j(1 To MaxCombo) For i = 1 To MaxCombo val = Trim(LCase(Me("ComboBox" & i).Value)) If val <> "" And val <> "*" Then ky(i) = val: n = True Else ky(i) = "" Next If Not n Then MsgBox "الرجاء تحديد معايير البحث", vbExclamation: GoTo CleanUp For i = 1 To MaxCombo If ky(i) <> "" Then f = f + 1: tb(f) = ColArr(i - 1): j(f) = ky(i) Next With Sh1 lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row If lastRow >= 5 Then .Range("A5:M" & lastRow).ClearContents End With data = OnRng: k = UBound(data, 1): t = 13 ReDim a(1 To k, 1 To t), criteria(1 To f) For r = 1 To k ok = True For i = 1 To f s = data(r, tb(i)) criteria(i) = IIf(IsDate(s), Format$(s, "yyyy/mm/dd"), LCase(Trim(CStr(s)))) If criteria(i) <> j(i) Then ok = False: Exit For Next If ok Then xtbl = xtbl + 1 For c = 1 To t: a(xtbl, c) = data(r, c): Next If IsDate(a(xtbl, 9)) Then a(xtbl, 8) = xDayName(Format(a(xtbl, 9), "dddd")) If IsDate(a(xtbl, 12)) Then a(xtbl, 11) = xDayName(Format(a(xtbl, 12), "dddd")) End If Next If xtbl > 0 Then Sh1.Range("A5").Resize(xtbl, t).Value = a AddBorders Sh1.Name CleanUp: SetApp True End Sub توحيد البحث في شيت واحد v7.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته اخي @AMIRBM تم تعديل الكود حسب طلبك ليعرض عمودين في ListBox داخل نموذج البحث مثلا (الإسم + التسلسل) يمكنك تعديله بما يناسبك وقد قمت بمحاولة تنقيحه وتحسينه ليكون أكثر كفاءة وتنظيما يرجى أولا تفريغ جميع الأكواد السابقة من النموذج ثم نسخ الكود التالي بالكامل Option Explicit Private ColArr As Variant Public Property Get WS() As Worksheet: Set WS = Sheets("add"): End Property Public Property Get dest() As Worksheet: Set dest = Sheets("search"): End Property Private Sub UserForm_Initialize() TextBox1.SetFocus 'قم بتحديد الأعمدة المرغوب عرضها ColArr = Array(2, 1) ' 2 = الإسم / 1 = التسلسل With ListBox1: .ColumnCount = UBound(ColArr) + 1: .ColumnWidths = "100pt;40pt": End With End Sub Private Sub TextBox1_Change() Dim c As Range, tmp As String, lastRow As Long, i As Long, listCount As Long ListBox1.Clear If IsEmpty(ColArr) Then Exit Sub tmp = Trim(TextBox1.Value) If Len(tmp) = 0 Then Exit Sub SetApp False lastRow = WS.Cells(WS.Rows.Count, ColArr(0)).End(xlUp).Row For Each c In WS.Range(WS.Cells(5, ColArr(0)), WS.Cells(lastRow, ColArr(0))) If InStr(1, c.Value, tmp, vbTextCompare) > 0 Then ListBox1.AddItem c.Value listCount = ListBox1.listCount For i = 1 To UBound(ColArr) ListBox1.List(listCount - 1, i) = c.EntireRow.Cells(1, ColArr(i)).Value Next i End If Next c SetApp True End Sub Private Sub CommandButton1_Click() Dim Irow As Long, f As Long, i As Long, xName As String, cnt As Boolean: cnt = False If ListBox1.listCount = 0 Then MsgBox "لا توجد نتائج للبحث", vbExclamation, "تنبيه": Exit Sub xName = Trim(TextBox1.Value): Irow = WS.Cells(WS.Rows.Count, ColArr(0)).End(xlUp).Row SetApp False For i = 5 To Irow If WS.Cells(i, ColArr(0)).Value = xName Then If Not cnt Then dest.Range("A8:L" & dest.Rows.Count).ClearContents f = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 dest.Range("A" & f).Resize(1, 12).Value = WS.Cells(i, 2).Resize(1, 12).Value cnt = True End If Next i If Not cnt Then MsgBox "لم يتم العثور على الاسم" & xName & " ضمن كشف المرحليات", vbInformation, "نتيجة البحث" SetApp True: Unload Me End Sub Private Sub ListBox1_Click() TextBox1.Value = ListBox1.List(ListBox1.ListIndex, 0) End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With On Error GoTo 0 End Sub المرحليات أوفيسنا v2.xlsm

المرجوا إرفاق الملف الذي يتضمن نفس البيانات والوظائف المذكورة للوقوف وراء سبب ظهور رسالة الخطأ معك

ما شاء الله جزاكم الله خيرا على هذا العمل الرائع والفكرة المميزة اخي @Foksh بناء على هده الفكرة القيمة قمت بتطوير الكود بحيث عند وجود أكثر من اختلاف بين القيم (قبل وبعد) يتم تمييز كل اختلاف بلون مختلف هذا فعلا يسهل جدا معرفة وتتبع الفروقات كما دكرت مع إظافة استخراج المادة التي تحتوي على الاختلاف إلى جانب الاسم والقيمة القبلية والبعدية لتوفير عرض واضح ومباشر للفروقات بالتوفيق......... نسخة معدلة من الكود لتحقيق هذا الهدف Private Sub Worksheet_Change(ByVal Target As Range) Dim r As Long, c As Long, Tbl1, Tbl2, a, b, tmp As Long, xCount As Long, key As String Dim xColor, cnt As Object, j As Long, i As Long, x As Long, ky As String Const départ = 3, ColArr = 18, début = 2, LastCol = 9, f = 9, Irow = 1 If Target.CountLarge > 1 Then Exit Sub Set cnt = CreateObject("Scripting.Dictionary") xColor = Array( _ RGB(255, 255, 0), RGB(255, 0, 0), RGB(0, 176, 80), RGB(0, 112, 192), RGB(255, 192, 0), RGB(112, 48, 160), _ RGB(255, 0, 255), RGB(0, 176, 240), RGB(146, 208, 80), RGB(255, 102, 0), RGB(204, 0, 153), RGB(0, 255, 255), _ RGB(255, 153, 204), RGB(153, 51, 0), RGB(102, 102, 255), RGB(255, 204, 153), RGB(51, 153, 102), RGB(153, 0, 0), _ RGB(0, 102, 204), RGB(204, 153, 255), RGB(255, 255, 153), RGB(204, 0, 0), RGB(0, 153, 0), RGB(0, 51, 102), _ RGB(255, 128, 0), RGB(102, 0, 102), RGB(0, 204, 204), RGB(255, 102, 102), RGB(102, 255, 102), RGB(102, 102, 153)) On Error GoTo CleanUp With Me If Intersect(Target, .Range(.Cells(départ, début), .Cells(départ + ColArr - 1, LastCol + f))) Is Nothing Then Exit Sub SetApp False .Range(.Cells(départ, début), .Cells(départ + ColArr - 1, LastCol + f)).Interior.colorIndex = xlNone With .Range("T:W"): .UnMerge: .ClearContents: End With Me.[T1:W1].Value = Array("الإسم", "المادة", "قبل", "بعد") tmp = 2: j = 0: xCount = 0 For r = départ To départ + ColArr - 1 b = .Cells(r, Irow).Value For c = début To LastCol Tbl1 = .Cells(r, c).Value: Tbl2 = .Cells(r, c + f).Value: a = .Cells(2, c).Value If IsEmpty(Tbl1) Then Tbl1 = "" If IsEmpty(Tbl2) Then Tbl2 = "" If CStr(Tbl1) <> CStr(Tbl2) Then xCount = xCount + 1 key = b & "|" & a & "|" & Tbl1 & "|" & Tbl2 If Not cnt.Exists(key) Then cnt.Add key, xColor(j Mod (UBound(xColor) + 1)) j = j + 1 End If .Cells(r, c).Interior.Color = cnt(key) .Cells(r, c + f).Interior.Color = cnt(key) .Cells(tmp, "T").Resize(1, 4).Value = Array(b, a, Tbl1, Tbl2) tmp = tmp + 1 End If Next c Next r If xCount > 0 Then .Cells(tmp, "T").Value = "إجمالي الاختلافات" .Cells(tmp, "U").Value = xCount x = 2: ky = .Cells(x, "T").Value For i = 3 To tmp If .Cells(i, "T").Value <> ky Or .Cells(i, "T").Value = "" Then If i - 1 > x Then .Range("T" & x & ":T" & i - 1).Merge x = i ky = .Cells(i, "T").Value End If Next i Else With .Range("T:W"): .UnMerge: .ClearContents: End With End If CleanUp: SetApp True Set cnt = Nothing End With End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub درجات المواد v4.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة أخرى أحب التنويه فقط أن كود الأستاذ @Foksh أكثر ديناميكية ومرونة لأنه يعتمد على دالة عامة تستقبل نطاقات متعددة مما يسمح باستخدامه لأي نطاق وفي أي ورقة دون الحاجة إلى تعديل داخلي في الكود بينما الكود الحالي مخصص لنطاق محدد وثابت داخل ورقة العمل وتم تقييده حسب البيانات الموجودة لديك في الملف هذا يجعل الكود أبسط وأسرع في التنفيذ لكنه أقل مرونة من حيث التعديل أو الاستخدام مع نطاقات مختلفة أو أوراق أخرى مستقبلا Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, j As Long, Tbl1 As Range, Tbl2 As Range Dim a As Range, b As Range, tmp As Range Dim xColor As Long: xColor = RGB(255, 204, 0) Dim ColArr As Long: ColArr = 8 Dim départ As Long: départ = 12 Dim début As Long: début = 3 On Error GoTo CleanExit Set Tbl1 = Range("B" & début).Resize(départ, ColArr) Set Tbl2 = Range("K" & début).Resize(départ, ColArr) If Intersect(Target, Union(Tbl1, Tbl2)) Is Nothing Then Exit Sub Application.EnableEvents = False Application.ScreenUpdating = False For Each tmp In Intersect(Target, Union(Tbl1, Tbl2)) i = tmp.Row - début + 1 If i >= 1 And i <= départ Then For j = 1 To ColArr Set a = Tbl1.Cells(i, j) Set b = Tbl2.Cells(i, j) If a.Value <> b.Value Then a.Interior.Color = xColor b.Interior.Color = xColor Else a.Interior.ColorIndex = xlNone b.Interior.ColorIndex = xlNone End If Next j End If Next tmp CleanExit: Application.EnableEvents = True Application.ScreenUpdating = True End Sub درجات المواد v3.xlsb

العفو أخي الكريم @algammal سعدنا دائما بمشاركتنا في إثراء الموضوع وتقديم الاقتراحات التي تساعدك على تحقيق النتائج المطلوبة والشكر الكبير للأستاذ الفاضل عبد الله على جهوده القيمة ومساهمته المتميزة بعد مراجعة الملف المقدم من أستاذنا الفاضل @عبدالله بشير عبدالله لاحظنا أنك تعتمد على معيار واحد فقط لجلب البيانات وليس عدة معايير كما ظننا في البداية لو عرفنا هذا منذ البداية لكان بإمكاننا تقديم حلول أبسط مما تم تطبيقه ضمن اليوزرفورم حيث كنا نعتقد أنك تحتاج بحثا ديناميكيا بعدة معايير مع ذلك لديك الآن عدة طرق مختلفة وجميعها فعالة ويمكنك اعتماد الأنسب منها حسب طبيعة عملك واحتياجاته

وعليكم السلام ورحمة الله تعالى وبركاته حل اخر لتجاهل ورقة ff مثلا Option Explicit Sub call1() Dim CrWS As Worksheet, WS As Worksheet Dim Tbl As Integer, lastCol As Integer Set CrWS = ThisWorkbook.Sheets("ff") Tbl = 4 lastCol = 21 CrWS.Range(CrWS.Cells(3, Tbl), CrWS.Cells(3, lastCol)).ClearContents For Each WS In ThisWorkbook.Sheets If WS.Name <> CrWS.Name Then CrWS.Cells(3, Tbl).Value = WS.Name Tbl = Tbl + 1 End If Next WS End Sub

أخي @algammal ربما ما لم تلاحظه هو أن القيم تعبأ على عناصر الكومبوبوكس مع تجاهل الفراغات والتكرارات ولهذا السبب تظهر معك مرة واحدة فقط وذلك لأن أرقام التسلسل الموجودة على ورقة معاشات هي نفسها الموجودة على الـ DATA ما يهمنا هنا هو جلب جميع البيانات المتوفرة على الورقتين التي تتضمن شروط التصفية المختارة وهذا واضح من خلال الإحصائيات أسفله وللتوضيح أكثر دعنا نجرب إضافة تسلسل جديد على ورقة المعاشات غير موجود مسبقا في DATA ونرى كيف سيتم التعامل معه لاحظ معي عند اختيار رقم التسلسل 1 الاحصائيات لدينا تظهر عدد الموظفين 2 على ورقة معاشات 1 وورقة DATA 1 أرفق لك آخر تحديث للملف توحيد البحث في شيت واحد v6.xlsb

تفضل أخي الكريم توحيد البحث في شيت واحد v5 .xlsb

وعليكم السلام ورحمة الله تعالى وبركاته إليك الكود المطلوب لحفظ جميع الشهادات في ملف PDF داخل مجلد باسم برنامج الكنترول شيت في نفس مكان المصنف Option Explicit Private Const CopyRange As String = "A5:J49" Private Const sFolder As String = "برنامج الكنترول شيت" Private Const NamePDF As String = "شهادات الأول" Private Const CrWS As String = "شهادات الأول بالقديرات" Private Sub CommandButton1_Click() Dim tbl As Boolean: tbl = False On Error GoTo CleanExit Dim f As Worksheet: Set f = Sheets(CrWS) Dim WS As Worksheet, début As Integer, fin As Integer, i As Integer, row As Integer Dim sPath As String, tempFile As String, tmp As Long, Rng As Range, OnRng As Range If IsEmpty(f.[J3].Value) Or Not IsNumeric(f.[J3].Value) Then _ MsgBox "يرجى تحديد رقم أول شهادة", vbExclamation, "تنبيه": Exit Sub début = f.[J3].Value: fin = f.[R3].Value 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 SetApp False On Error Resume Next Set WS = Sheets("PDF") If Not WS Is Nothing Then Application.DisplayAlerts = False: WS.Delete: Application.DisplayAlerts = True Set WS = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Name = "PDF": WS.DisplayRightToLeft = True On Error GoTo 0 If WS Is Nothing Then: GoTo CleanExit tempFile = ThisWorkbook.Path & "\" & sFolder If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile tmp = 1 Set OnRng = f.Range(CopyRange) For i = début To fin Step 5 f.[J3].Value = i: Set Rng = WS.Cells(tmp, 2) OnRng.Copy Rng.PasteSpecial Paste:=xlPasteValues: Rng.PasteSpecial Paste:=xlPasteFormats Rng.PasteSpecial Paste:=xlPasteColumnWidths For row = 1 To OnRng.Rows.Count WS.Rows(tmp + row - 1).RowHeight = OnRng.Rows(row).RowHeight - 1.5 Next If i + 5 <= fin Then WS.HPageBreaks.Add Before:=WS.Cells(tmp + OnRng.Rows.Count, 1) tmp = tmp + OnRng.Rows.Count + 1 Next 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) .PaperSize = xlPaperA4: .CenterHorizontally = True: .CenterVertically = False End With sPath = tempFile & "\" & NamePDF & ".pdf" On Error Resume Next WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False tbl = (Err.Number = 0) On Error GoTo 0 f.[J3].Value = 1 WS.Delete CleanExit: SetApp True MsgBox IIf(tbl, _ "تم تصدير جميع الشهادات بنجاح" & vbNewLine & _ "تم حفظ الملف باسم: " & NamePDF & vbNewLine & "في المجلد: " & sFolder, _ "حدث خطأ يرجى المحاولة مرة أخرى"), IIf(tbl, vbInformation, vbCritical), _ "PDF" & "تصدير الشهادات بصيغة" End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable End With End Sub وإليك في المرفقات شكل الملف PDF المستخرج بعد تنفيذ العملية لتأخذ فكرة واضحة عن النتيجة النهائية شهادات الأول والثانى- الصف الأول.rar شهادات الأول.pdf

وعليكم السلام ورحمة الله تعالى وبركاته إذن أخي الكريم على الأقل قم بإرفاق ملفك وبه الأكواد المطلوبة مع ذكر النواة التي تستخدمها حاليا هل هي 32 أو 64 لتوضيح ما يظهر معك من أخطاء عند محاولة تنفيذ الكود لا يمكن العمل على التخمين !!!

أخي @algammal جزاك الله خيرا على كلماتك الطيبة وطرحك الرائع وأسأل الله أن يجعل عملنا هذا في ميزان حسناتنا جميعا سررت كثيرا بتقديرك وتشجيعك الكريم وهذا هو الدافع الحقيقي للاستمرار والعطاء بخصوص الملاحظات التي أشرتم إليها في مشاركتكم السابقة للأستاذ @عبدالله بشير عبدالله جزاه الله خيرًا على تفانيه الدائم في إثراء المواضيع بمساهماته القيمة فقد تم الاطلاع عليها بعناية والعمل على تطبيقها على الـ UserForm أيضا وذلك لضمان تجربة أكثر تكاملا وسلاسة في الأداء 1) قائمة أسماء أيام الأسبوع في الخلايا (H5) و(K5) تم إضافة ميزة البحث حسب اليوم بشكل مباشر وذلك من خلال استبدال المعادلات في ورقة DATA لتتوافق مع اللغة العربية بالشكل التالي: يوم تاريخ الميلاد =IF(I5="خطأ بالرقم القومى", "", IF(I5<>"", CHOOSE(WEEKDAY(I5, 2), "الإثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السبت", "الأحد"), "")) يوم تاريخ المعاش =IF(L5="", "", CHOOSE(WEEKDAY(L5, 2), "الإثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السبت", "الأحد")) 2) ملاحظات الخلية (M5) نظرا لاستخدام UserForm فلا حاجة لإدراج قائمة منسدلة يدويا لأن عناصر الـ ComboBox تتعرف تلقائيا على القيم المختلفة الموجودة في الأعمدة مع الحرص على عدم تكرارها هذا يسهل عملية التصفية ويجعل الواجهة أكثر ديناميكية وسلاسة في الاستخدام 3) الخلية (A5) والبحث بالترقيم التسلسلي: تم تجاهل الترقيم التسلسلي في البحث لأنه لم يعد ضروريا مع اعتماد واجهة الـ UserForm التي تتعامل مع البيانات مباشرة وتغطي كافة الأعمدة المتوفرة ضمن النطاق A:M في الرقتين (Data و معاشات) ومع ذلك إذا كانت هناك حاجة حقيقية لإستخدام المسلسل لأغراض معينة (مثل تتبع أو فرز إضافي) أو البحث بواسطته فيمكننا طبعا إضافته بكل سهولة لا ننسى تقديم الشكر الجزيل لكل من الأساتذة @عبدالله بشير عبدالله و @Foksh الذين ساهموا في إثراء الموضوع بملاحظاتهم القيمة وجهودهم المباركة جزاكم الله خيرا توحيد البحث في شيت واحد v4.xlsb

ConvertDates.rar

Private Sub CommandButton1_Click() SetApp False Dim lastRow As Long:lastRow = Sh1.Cells(Sh1.Rows.Count, "A").End(xlUp).Row If lastRow >= 5 Then With Sh1.Range("A5:M" & lastRow) .ClearContents .Borders.LineStyle = xlNone End With End If UpdateCounter SetApp True End Sub توحيد البحث في شيت واحد v3.xlsb

وعليكم السلام ورحمة الله وبركاته جرب هدا Option Explicit Const Salaries As Double = 250000 Sub SplitTables() Dim WS As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet Dim lastRow As Long, i As Long, Tbl1 As Long, Tbl2 As Long, tbl3 As Long, arr Dim sum1 As Double, sum2 As Double, sum3 As Double, OnRng As Range, CrWS As Variant Dim tmp() As Double, n() As Long, ky() As Boolean, j() As Boolean, k() As Boolean SetApp False Set WS = ThisWorkbook.sheets("Net") TmpWS "تقسيم1": TmpWS "تقسيم2": TmpWS "تقسيم3" Set Sh1 = ThisWorkbook.sheets("تقسيم1") Set Sh2 = ThisWorkbook.sheets("تقسيم2") Set Sh3 = ThisWorkbook.sheets("تقسيم3") CrWS = Array(Sh1, Sh2, Sh3) For Each arr In CrWS arr.Columns("A:H").Clear arr.DisplayRightToLeft = True Next lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row ReDim tmp(2 To lastRow), n(2 To lastRow), ky(2 To lastRow) ReDim j(2 To lastRow), k(2 To lastRow) For i = 2 To lastRow tmp(i) = WS.Cells(i, "D").Value n(i) = i Next i Set OnRng = WS.[A1:H1] OnRng.Copy Sh1.[A1]: OnRng.Copy Sh2.[A1]: OnRng.Copy Sh3.[A1] Tbl1 = 2: Tbl2 = 2: tbl3 = 2: sum1 = 0: sum2 = 0: sum3 = 0 For i = 2 To lastRow If tmp(i) > Salaries Then WS.Rows(n(i)).Copy Sh3.Rows(tbl3) tbl3 = tbl3 + 1 ky(i) = True sum3 = sum3 + tmp(i) End If Next i If Not WsTotal(tmp, ky, Salaries, j) Then Call WsTotal(tmp, ky, Salaries, j) For i = 2 To lastRow: If j(i) Then ky(i) = True Next i If Not WsTotal(tmp, ky, Salaries, k) Then Call WsTotal(tmp, ky, Salaries, k) For i = 2 To lastRow If j(i) Then WS.Range("A" & n(i) & ":H" & n(i)).Copy Sh1.Range("A" & Tbl1) sum1 = sum1 + tmp(i) Tbl1 = Tbl1 + 1 ElseIf k(i) Then WS.Range("A" & n(i) & ":H" & n(i)).Copy Sh2.Range("A" & Tbl2) sum2 = sum2 + tmp(i) Tbl2 = Tbl2 + 1 ElseIf Not ky(i) Then WS.Range("A" & n(i) & ":H" & n(i)).Copy Sh3.Range("A" & tbl3) sum3 = sum3 + tmp(i) tbl3 = tbl3 + 1 End If Next i AddTotal Sh1, Tbl1, sum1: AddTotal Sh2, Tbl2, sum2: AddTotal Sh3, tbl3, sum3 ColArr CrWS WS.Activate MsgBox "تم تقسيم جدول الرواتب بنجاح", vbInformation SetApp True End Sub Private Sub AddTotal(sht As Worksheet, ling As Long, total As Double) sht.Cells(ling, "C").Value = "الإجمالي" sht.Cells(ling, "D").Value = Format(total, "0.00") With sht.Range(sht.Cells(ling, "C"), sht.Cells(ling, "D")) .Font.Bold = True: .Interior.Color = RGB(220, 230, 241) End With End Sub Private Sub ColArr(sheets As Variant) Dim sht As Variant For Each sht In sheets sht.Columns("A:H").AutoFit Next sht End Sub Private Sub TmpWS(sheetName As String) Dim WS As Worksheet On Error Resume Next Set WS = ThisWorkbook.sheets(sheetName) On Error GoTo 0 If WS Is Nothing Then Set WS = ThisWorkbook.sheets.Add(After:=ThisWorkbook.sheets(ThisWorkbook.sheets.Count)) WS.Name = sheetName End If End Sub حافظة إلكترونية مصارف التجاري052025 V-2.xls