محمد هشام.

شكل بياناتك غير مفهوم يصعب التعامل معه في ظل غياب نمودج أو عينة لشكل النتائج المتوقعة ممكن توضح لنا كيف حصلت مثلا على هده النتائج

جرب هدا Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("N5")) Is Nothing Then Dim a As Variant, i As Long, k As Long, schoolName As String Dim n() As Variant, cnt As Long, count As Long, lr As Long, r As Long Dim WS As Worksheet: Set WS = Sheets("اسماء العاملين ") Dim dest As Worksheet: Set dest = Sheets("طباعة كشف المدرسة") schoolName = Me.Range("N5").Value If schoolName = "" Then Exit Sub a = WS.Range("A7:F" & WS.Cells(WS.Rows.count, "A").End(xlUp).Row).Value cnt = 0 For i = 1 To UBound(a, 1) If a(i, 6) = schoolName Then cnt = cnt + 1 End If Next i If cnt = 0 Then MsgBox "إسم المدرسة غير موجود في قاعدة البيانات", vbExclamation Exit Sub End If On Error Resume Next lr = dest.Columns("A:I").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If lr >= 9 Then dest.Range("A9:E" & lr).ClearContents dest.Range("I9:I" & lr).ClearContents End If ReDim n(1 To cnt, 1 To 5) k = 1 For i = 1 To UBound(a, 1) If a(i, 6) = schoolName Then n(k, 1) = k n(k, 2) = a(i, 2): n(k, 3) = a(i, 3) n(k, 4) = a(i, 4): n(k, 5) = a(i, 5) k = k + 1 End If Next i With dest .Cells(9, 1).Resize(cnt, 5).Value = n .Cells(9, 9).Resize(cnt, 1).Value = schoolName count = Application.WorksheetFunction.CountA(.Range("B9:B" & _ .Cells(.Rows.count, "B").End(xlUp).Row)) .[H4].Value = count End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End If End Sub سرى الشهادة الاعدادية.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته طلبك غير واضح أخي الكريم

أخي @mohamed.youssef للعلم إحتمال 90% من حصولك على إجابة صحيحة تكمن في طريقة طرح طلبك الصيغة التي قمت بطرح بها طلبك في أول مشاركة (التعديل وربط الألوان.... ) كيف نفهم نحن أنك تريد جلب التواريخ من إلى إذن الكود المقترح يقوم بجلب القيم الفريدة من عمود A ونسخ القيم من عمود G بشرط التاريخ وعند وجود تواريخ مكررة يتم دمج القيم المتعلقة بها في خلية واحدة مثلا 156-456..... وهكذا أما طلبك الحالي التاريخ من إلى يرجى إرفاق عينة لشكل البيانات المتوقعة للتوضيح وان شاء الله سوف نحاول مساعدتك

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub ItemsRollKgmsKnt() Dim d1 As Object, d2 As Object Dim OnRng() As Variant, a, g, d As Variant Dim tmp As Integer, n As Integer, mx As Integer Dim WS As Worksheet: Set WS = Sheets("KN") Set d1 = CreateObject("Scripting.Dictionary") Set d2 = CreateObject("Scripting.Dictionary") a = WS.Range("A2:A" & WS.[A65000].End(xlUp).Row).Value g = WS.Range("G2:G" & WS.[A65000].End(xlUp).Row).Value d = WS.Range("D2:D" & WS.[A65000].End(xlUp).Row).Value For i = 1 To UBound(a, 1) If IsNumeric(a(i, 1)) And a(i, 1) <> "" Then If Not d1.exists(a(i, 1)) Then d1(a(i, 1)) = d1.Count + 1 End If Next i mx = 31 ReDim OnRng(1 To d1.Count, 1 To mx + 1) For i = 1 To UBound(a, 1) If IsNumeric(a(i, 1)) And a(i, 1) <> "" Then n = d1(a(i, 1)) tmp = Day(CDate(d(i, 1))) If tmp >= 1 And tmp <= 31 Then OnRng(n, 1) = a(i, 1) If OnRng(n, tmp + 1) = "" Then OnRng(n, tmp + 1) = g(i, 1) Else OnRng(n, tmp + 1) = OnRng(n, tmp + 1) & "-" & g(i, 1) End If End If End If Next i With Sheets("MM") .Range("A2").Resize(d1.Count, mx + 1).Value = OnRng .Columns.AutoFit End With End Sub KNTPROD V1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Dim PassProtect As String, OnRng As Range Private Const Clé As String = "1234" Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property Sub Data_Protection() Dim linge As Variant Do linge = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If linge = False Then Exit Sub If Not IsNumeric(linge) Or linge < 1 Or linge > WS.Rows.Count Then: MsgBox "خطأ في الإدخال" Exit Do Loop Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' قم بتعديل النطاق بما يناسبك Set OnRng = WS.Range("A2:M" & linge) With WS If .ProtectContents Then .Unprotect password:=Clé .Cells.Locked = False OnRng.FormulaHidden = True OnRng.Locked = True .Protect password:=Clé End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox linge & ":" & "تم قفل الحسابات بنجاح لغاية الصف ", vbInformation End Sub '======================================================================= Sub Data_UnProtection() Dim result As VbMsgBoxResult Do PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = "" Then Exit Sub If PassProtect = Clé Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual WS.Unprotect password:=Clé WS.Cells.Locked = False WS.Cells.FormulaHidden = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation Exit Sub Else result = MsgBox( _ "كلمة المرور غير صحيحة" & vbNewLine & "هل ترغب في المحاولة مرة أخرى؟", _ vbCritical + vbYesNo, "خطأ في كلمة المرور") If result = vbNo Then MsgBox "تم إلغاء العملية", vbInformation Exit Sub End If End If Loop End Sub غلق المدى المحدد .xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بما أنك تستخدم الأكواد على الملف أعتقد أنه بإمكانك ربط الكود بأي شكل وتقوم بوضعه فوق الصورة عادي نفس الفكرة المقترحة من الأخ @أبومروان بواسطة الأكواد مع إمكانية تحديد إسم الصورة والتعليق المرغوب إظهاره .يمكنك إظافة أي عدد من الأشكال وتعديل النطاقات بما يتناسب مع إحتياجاتك wor-v2.xlsm

بما أنك لم تجب عن سؤالي إليك طريقة أخرى ستقوم بإظافة عنصر جديد بإسم Line لإستخراج رقم صف المحدد عند الإختيار من عناصر الكومبوبوكس وإعتمادا عليه سنقوم بتعديل وحدف الصفوف Private Sub SearchData() Dim fnd As Range Dim ColA As String, ColB As String, ColC As String Dim criteria As Range, found As Boolean Dim rowNum As Long ColA = Me.ComboBox1.Value ColB = Me.ComboBox2.Value ColC = Me.ComboBox3.Value If Len(ColA) = 0 Then Exit Sub Set criteria = WS.Range("A4:C" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row) found = False For Each fnd In criteria.Rows If fnd.Cells(1, 1).Value = ColA And _ (ColB = "" Or Format(fnd.Cells(1, 2).Value, "dd-mmm") = ColB) And _ (ColC = "" Or fnd.Cells(1, 3).Value = ColC) Then For i = 1 To 62 Me.Controls("TextBox" & i).Value = fnd.Cells(1, i).Value Next i rowNum = fnd.Row found = True Exit For End If Next fnd If Not found Then ClearTextBoxes Me.Line.Value = "" Else Me.Line.Value = rowNum End If End Sub Private Sub CommandButton2_Click() Dim r As Integer, n As Variant Dim i As Integer, X As Integer Dim rowNum As Long, fnd As Range If IsNumeric(Me.Line.Value) Then rowNum = CLng(Me.Line.Value) Else MsgBox " يرجى تحديدالبيانات المرغوب تعديلها", vbExclamation Exit Sub End If If rowNum < 5 Then: Exit Sub If SaisieText(1, 2) Then Exit Sub r = MsgBox("تعديل البيانات؟", vbYesNo, "تأكيـــد") If r <> vbYes Then Exit Sub Application.ScreenUpdating = False Set fnd = WS.Cells(rowNum, 1) For i = 1 To 62 On Error Resume Next n = Me.Controls("TextBox" & i).Value On Error GoTo 0 If IsDate(n) Then fnd.Offset(0, i - 1).Value = CDate(n) Else fnd.Offset(0, i - 1).Value = n End If Next i Call UpdateNum(WS) Clear_TextBox UserForm_Initialize Application.ScreenUpdating = True MsgBox "تم التعديل بنجاح", vbInformation End Sub Private Function SaisieText(startIdx As Integer, endIdx As Integer) As Boolean Dim i As Integer, X As Integer Dim arr() As String, TexArr As String For i = startIdx To endIdx If Me.Controls("TextBox" & i).Value = "" Then TexArr = Me.Controls("cnt" & i).Caption ReDim Preserve arr(X) arr(X) = TexArr X = X + 1 End If Next i If X > 0 Then MsgBox ": يرجى التحقق من " & Chr(10) & Join(arr, " - "), vbInformation SaisieText = True Else SaisieText = False End If End Function ترحيل مع كمبوبوكس البحث بحقلين V3.xlsm

ليس هناك اي خطأ في الكود لاكنني أعتقد اخي أنك لم تنتبه لما جاء في المشاركة السابقة بمعنى عن محاولة التعديل او الحدف يجب تطابق قيم عناصر التيكست بوكس 1-2-3 مع بيانات الصف المرغوب تنفيد الاجراء عليه وهدا بسبب البيانات المكررة 1) السؤال هل انت بحاجة لتعديل رقم المسلسل والتاريخ 2) في وضعنا الحالي لنفترض ان شكل البيانات لدينا بهدا الشكل ولديك رغبة بتعديل او حدف الصف رقم 2 مثلا كيف يمكننا تحديده والقيم مكررة على عمود المسلسل والتاريخ م التاريخ رقم الموظف المنصب الوظيفي تاريخ استلام المنصب الشهادة بعد التعيين 1 2 1 01-Oct 1 المنصب الوظيفي 1 استلام العمل1 شهادة 1 شهادة 2 1 01-Oct 2 المنصب الوظيفي 2 استلام العمل2 شهادة 2 شهادة 3 1 01-Oct 3 المنصب الوظيفي 3 استلام العمل3 شهادة 3 شهادة 4 3 01-Oct 1 المنصب الوظيفي 4 استلام العمل4 شهادة 4 شهادة 5 3 01-Oct 2 المنصب الوظيفي 5 استلام العمل5 شهادة 5 شهادة 6

أخي @ehabaf2 أظن اننا بحاجة لإفراغ اليوزرفورم من جميع الأكواد السابقة وإعادة إظافة أكواد جديدة لتتناسب مع طلبك 1) تعديل أعمدة تعبئة عناصر الكومبوبوكس 2) تعديل كود الترحيل للحصول على تسلسل عمود C (رقم الموظف) بداية من رقم 1 للقيمة الفريدة مع تسلسلها عند تكرار نفس المسلسل ونفس التاريخ 3) تعديل كود تحديث البيانات بحيث يتم تعديل الصف بشرط تطابق المسلسل والتاريخ ورقم الموظف (TEXTBOX1-TEXTBOX2-TEXTBOX3) 4) نفس الفكرة على كود الحدف تفاديا لحدف أي بيانات لا تتطابق مع القيم المختارة بالعناصر خاصة انها مكررة (TEXTBOX1-TEXTBOX2-TEXTBOX3) وضمان إعادة التسلسل للشكل المطلوب كان بامكاني الإكتفاء بنشر كود الترحيل فقط بعد إظافة التسلسل المطلوب لاكنك ستواجه مشاكل عند محاولة الحدف أو التعديل وسنظطر الى إعادة فتح موضوع جديد 😂 لاكن ولا يهمك بالنسبة لتعبئة عناصر الكومبوبوكس تم تعديلها على حسب طلبك كما في الصورة اسفله كود الترحيل بعد إظافة تسلسل عمود C بالشروط المدكورة Private Sub CommandButton1_Click() 'ترحيـل البيانات Dim i As Integer, lastRow As Long, choose As Integer Dim x As Integer, arr() As String, TexArr As String For i = 1 To 3 If Me.Controls("TextBox" & i).Value = "" Then TexArr = Me.Controls("cnt" & i).Caption ReDim Preserve arr(x) arr(x) = TexArr x = x + 1 End If Next i If x > 0 Then MsgBox "يرجى التحقق من " & Chr(10) & Join(arr, " - "), vbInformation Exit Sub End If choose = MsgBox("ترحيـل البيانات؟", vbYesNo, "تأكيـــد") If choose <> vbYes Then Exit Sub Application.ScreenUpdating = False lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1 For i = 1 To 62 If i <> 3 Then On Error Resume Next n = Me.Controls("TextBox" & i).Value On Error GoTo 0 With ws.Cells(lastRow, i) If IsDate(n) Then .Value = CDate(n) Else .Value = n End If End With End If Next i Call UpdateNum(ws) For i = 1 To 62: Me.Controls("TextBox" & i).Value = "": Next i For i = 1 To 3: Me.Controls("ComboBox" & i).Value = "": Next i UserForm_Initialize Application.ScreenUpdating = True End Sub الدالة التالية لتسلسل عمود رقم الموظف سنقوم بإستدعائها سواءا عند الترحيل أو الحدف وكدالك التعديل لضمان الحفاظ على التسلسل الصحيح عند كل إجراء Function UpdateNum(ws As Worksheet) As Boolean On Error GoTo ErrorHandler Dim lastRow As Long, OnRng As Range Dim n() As Variant, ar() As Variant Dim src As Long, tmp As String Dim Dict As Object Set Dict = CreateObject("Scripting.Dictionary") lastRow = ws.Columns("A:B").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set OnRng = ws.Range("A5:B" & lastRow) ar = OnRng.Value2 ReDim n(1 To UBound(ar, 1), 1 To 1) For i = 1 To UBound(ar, 1) If ar(i, 1) <> "" And ar(i, 2) <> "" Then tmp = ar(i, 1) & "|" & ar(i, 2) If Not Dict.Exists(tmp) Then src = 1 Dict.Add tmp, src Else src = Dict(tmp) + 1 Dict(tmp) = src End If n(i, 1) = src Else n(i, 1) = "" End If Next i ws.Range("C5").Resize(UBound(n, 1), 1).Value = n UpdateNum = True Exit Function ErrorHandler: UpdateNum = False End Function الملف المرفق يتضمن تعديل جميع الاكواد المدكورة سابقا ترحيل مع كمبوبوكس البحث بحقلين V2.xlsm

تمام ممكن نعدلها لاكن كود الترحيل يتضمن تسلسل للبيانات في عمود A ما يمنع تكرار القيم به هل ستقوم بحدفه وادخال التسلسل يدويا

هدا ما تم الاشتغال عليه فعلا بحيث يكون البحث ديناميكيا بين جميع العناصر 1-2-3 بمعنى عند إختيار قيمة كومبوبوكس 1 يتم تعبئة كومبوبوكس 2 بالقيم المتاحة فقط وعند الإختيار من 2 يتم تعبئة كومبوبوكس 3 بالقيم المتاحة يشرط 1 و 2 فقط لاحظ الصورة المتحركة مثلا عند اختيار رقم التسلسل 4 طلبك غير واضح هل تقصد تسلسل للبيانات عند الترحيل او مادا

هل من الممكن إرفاق عينة للنتائج المتوقعة يدويا للتوضيح أكثر

العقو اخي @tahar

وعليكم السلام ورحمة الله تعالى وبركاته 1) بما أن الملف لا يتضمن معادلات حاول تجربة تقليل حجم الملف عبر إزالة الصفوف أو الأعمدة الفارغة وأي بيانات غير ضرورية مع التأكد من عدم وجود تنسيقات زائدة (مثل الألوان أو أنماط الخلايا) الغير مستخدمة فهي تؤثر على سرعة التحميل 2) في حالة وجود كود VBA مثلا في حدث ورقة الإدخال يمكن أن يكون سببا في عملية البطئ التي تواجهك خاصة إذا كان الكود يقوم بعمليات معقدة أو يتضمن حلقات 3) قم بحفظ الملف بصيغة xlsb حيث إن هذه الصيغة عادة ما تكون أخف بالتوفيق.......

Book1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته ترحيل مع كمبوبوكس البحث بحقلين).xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب إحدى المعادلات التالية =IFERROR(INDEX(الرئيسة!B:B, MATCH(H6, الرئيسة!A:A, 0)),"") او =IFERROR(VLOOKUP(H6,الرئيسة!A:B, 2, FALSE),"") او استخدام الأكواد Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$H$6" Then Dim tmp As String, Rng As Range, References As Variant tmp = Target.Value Set Rng = Me.Range("I6") If tmp = "" Then: Rng.Value = "": Exit Sub On Error Resume Next References = Application.WorksheetFunction.VLookup(tmp, _ Sheets("الرئيسة").Range("A:B"), 2, False) On Error GoTo 0 If Not IsError(References) Then Rng.Value = References End If End If End Sub Book1.xlsx

ربما هدا ما تقصده تعديل فورم V6 -.rar

Option Explicit Sub test() Dim arr As Variant, i As Long, Irow As Long Dim dictA As Object, dictB As Object, dictC As Object, dictD As Object Dim n As Variant, a As Variant, b As Variant, c As Variant Dim WS As Worksheet: Set WS = Sheets("Sheet1") With WS Irow = .Columns("A:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If WorksheetFunction.CountA(.Range("A2:A" & Irow)) = 0 And _ WorksheetFunction.CountA(.Range("B2:B" & Irow)) = 0 Then MsgBox "لا توجد بيانات للمقارنة", vbExclamation Exit Sub End If 'Code ............. .................. Set dictC = CreateObject("Scripting.Dictionary") Set dictD = CreateObject("Scripting.Dictionary") For i = 2 To Irow If WS.Cells(i, 3).Value <> "" Then dictC(WS.Cells(i, 3).Value) = True If WS.Cells(i, 4).Value <> "" Then dictD(WS.Cells(i, 4).Value) = True Next i For i = 2 To Irow If WS.Cells(i, 1).Value <> "" Then If dictC.exists(WS.Cells(i, 1).Value) Or dictD.exists(WS.Cells(i, 1).Value) Then WS.Cells(i, 1).Interior.Color = RGB(255, 255, 0) End If End If If WS.Cells(i, 2).Value <> "" Then If dictC.exists(WS.Cells(i, 2).Value) Or dictD.exists(WS.Cells(i, 2).Value) Then WS.Cells(i, 2).Interior.Color = RGB(255, 165, 0) End If End If Next i Application.ScreenUpdating = True End Sub مقارنة 3.xlsb

لا علاقة له بالمسلسل التحديد يتم بواسطة رقم الصف

نعم التعديل والاظافة ليس لها علاقة بالمسلسل انت من تضيفه يدويا فقط يتم فقدانه في حالة حدف الصف

نعم اخي المشكلة في طريقة البحث التي تستخدمها لهدا سنعتمد على طريقة متقدمة نوعا ما لتنفيد طلبك وتحديد الصف بدون الاعتماد على إسم او رقم الملف مع اظافة إمكانية البحث والفلترة بأي عمود Private Sub ListBox1_Click() Dim lastRow As Long: lastRow = f.Rows.Count f.Range("A7:A" & lastRow).Interior.ColorIndex = xlNone For i = 1 To OnRng Me("textbox" & i) = Me.ListBox1.Column(i - 1) Next i Me.N_ligne = Me.ListBox1.Column(i - 1) rng = Me.N_ligne + 6 If rng > 0 Then With f .Range(.Cells(rng, "C"), .Cells(rng, "N")).Select .Cells(rng, "A").Interior.Color = RGB(0, 0, 255) End With End If End Sub تعديل فورم V5 -.rar

أعتدر أخي @عادل ابوزيد خطأ لم انتبه له😂 الكود ينفد طلبك لاكن يجب وضع قيمة البحث بعد الصف الخاص بنقل البيانات لعناصر التيكست بهدا الشكل ليس قبلها للتوضيح 1) الفكرة انه يقوم بتحديد الصف بناءا على قيمة textbox4 في عمود ( F ) اسم صاحب المعاش يمكنك تعديلها بما يناسبك For i = 0 To 11 Controls("TextBox" & (i + 1)).Value = IIf(ListBox1.ListIndex <> -1, ListBox1.Column(i), "") Next i Clé = TextBox4.Value 2) في حالة كانت لديك أسماء مكررة يمكنك اظافة شروط اخرى كما في المثال التالي بحيث سنعتمد على اسم صاحب المعاش و رقم الملف وعند التحقق من تطابق الشرطين سيتم تحديد الصف وفي حالة وجود تكرار لنفس البيانات سيقوم بتحديد جميع الصفوف المكررة يمكنك تحميل الملف في المشاركة السابقة بعد تصحيح الخطأ وإختيار ما يناسبك Private Sub ListBox1_Click() Dim ws As Worksheet, OnRng As Range, ColFind As Range Dim Colstar As Integer, ColEnd As Integer, n As Long Dim Clé As Variant, Clé2 As Variant, tmp As Range, f As String, i As Byte Set ws = Sheets("البداية") Colstar = 3: ColEnd = 14 For i = 0 To 11 Controls("TextBox" & (i + 1)).Value = ListBox1.Column(i) Next i TextBox15.Value = ListBox1.ListIndex + 1 Clé = TextBox4.Value: Clé2 = TextBox3.Value Set tmp = Nothing n = 0 Set OnRng = ws.Range(ws.Cells(7, "F"), ws.Cells(ws.Rows.Count, "F").End(xlUp)) Set ColFind = OnRng.Find(Clé, LookIn:=xlValues, LookAt:=xlWhole) If Not ColFind Is Nothing Then f = ColFind.Address Do If ws.Cells(ColFind.row, "E").Value = Clé2 Then n = n + 1 If tmp Is Nothing Then Set tmp = ColFind.EntireRow Else Set tmp = Union(tmp, ColFind.EntireRow) End If End If Set ColFind = OnRng.FindNext(ColFind) Loop While Not ColFind Is Nothing And ColFind.Address <> f End If If n > 0 Then On Error Resume Next ws.Activate If Not tmp Is Nothing Then Dim rng As Range For Each row In tmp.Rows If rng Is Nothing Then Set rng = ws.Range(ws.Cells(row.row, Colstar), ws.Cells(row.row, ColEnd)) Else Set rng = Union(rng, ws.Range(ws.Cells(row.row, Colstar), ws.Cells(row.row, ColEnd))) End If Next row rng.Select End If On Error GoTo 0 End If End Sub

بعد إدن الأستاد @عبدالله بشير عبدالله تعديل بسيط على الكود الخاص به أخي @reem2009a جرب بهذه الطريقة لا تحتاج لتحديد مسار سطح المكتب. عند تنفيذ الكود سيفتح لك مربع حوار لإختار ملف رقم1 وملف رقم2 مما سيغنيك عن تحديد أسماء المصنفات داخل الكود ربما يناسبك filePath1 = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", , "Select First File") If filePath1 = "False" Then Exit Sub filePath2 = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx", , "Select Second File") If filePath2 = "False" Then Exit Sub On Error GoTo ErrorHandler Set wb1 = Workbooks.Open(filePath1) Set wb2 = Workbooks.Open(filePath2) Set resultWs = ThisWorkbook.Sheets("Sheet1") resultWs.Cells.ClearContents resultWs.Range("A1:D1").Value = Array("اسم الموظف", "الحالة", _ Left(wb1.Name, InStrRev(wb1.Name, ".") - 1), Left(wb2.Name, InStrRev(wb2.Name, ".") - 1)) 'Code........... End Sub نتائج المقارنة.xlsb