محمد هشام.

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

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Private Const ShName As String = "جدول عام" Sub Coloring_Classes() On Error GoTo EndClear SetApp False Dim Sh As Worksheet: Set Sh = ThisWorkbook.Sheets(ShName) Dim i As Long, r As Long, c As Long, ColAL As Long, ColA As Long Dim tmps As Object: Set tmps = CreateObject("Scripting.Dictionary") Sh.Range("B6:AJ23").Interior.ColorIndex = xlNone ColAL = Sh.Cells(Sh.Rows.Count, "AL").End(xlUp).Row ColA = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Row For i = 5 To ColAL If Len(Sh.Cells(i, "AL").Value) > 0 Then If Sh.Cells(i, "AM").Interior.ColorIndex <> xlColorIndexNone Then tmps(Sh.Cells(i, "AL").Value) = Sh.Cells(i, "AM").Interior.Color End If End If Next i For r = 5 To ColA If tmps.exists(Sh.Cells(r, "A").Value) Then For c = 2 To 36 With Sh.Cells(r, c) If Len(.Value) > 0 Then .Interior.Color = tmps(Sh.Cells(r, "A").Value) End With Next c End If Next r 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 جدول.xlsm

من المفروض أولا كما سبق الدكر محاولة إلغاء دمج الخلايا لضمان أن الكود يتعامل مع كل خلية على حدة وحصولك على نتائج صحيحة جرب هدا هل يناسيك 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

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك تنفيذ ذلك باستخدام الأكواد ولكن أعتقد أنه سيكون من الضروري أولا تنظيم البيانات في ورقة العمل Menuf بشكل جيد ومن الأفضل كذلك فك الخلايا المدمجة لضمان الحصول على نتائج دقيقة ووضع الدوائر حول القيم المطلوبة بشكل صحيح إذا كان هذا يناسبك فالكود التالي ربما يساعدك في تنفيذ طلبك ' تحديد عرض الدائرة Const xWidth As Single = 40 ' تحديد طول الدائرة Const xlength As Single = 55 Sub AddDrawCircles() Dim dest As Worksheet, CrWS As Worksheet Dim Search As String, dataValue As String Dim ColArr As Long, lastRow As Long, i As Long, col As Long Dim cell As Range, OnRng As Range, shp As Shape, lastCol As Long Dim n As Boolean, a() As String, ky As Variant, r() As String On Error GoTo SupApp Set CrWS = Sheets("main sheet"): Set dest = Sheets("MenuF") Search = Trim(dest.[B1].Value) If Search = "" Then MsgBox "يرجى إدخال قيمة البحث", vbExclamation: Exit Sub SetApp False lastRow = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow If Trim(CrWS.Cells(i, 1).Value) = Search Then ColArr = i: n = True: Exit For Next i If Not n Then MsgBox "قيمة البحث غير موجودة على قاعدة البيانات", vbExclamation, "إنتبـــاه": GoTo CleanUp For Each shp In dest.Shapes: If Left(shp.Name, 4) = "Oval" Then shp.Delete Next shp lastCol = CrWS.Cells(ColArr, Columns.Count).End(xlToLeft).Column ReDim a(1 To lastCol - 1) For col = 2 To lastCol: a(col - 1) = Trim(CrWS.Cells(ColArr, col).Value): Next col Set OnRng = dest.Range("A3:I7") For col = 1 To 6 dataValue = a(col) If dataValue <> "" Then For Each cell In OnRng If cell.Value <> "" Then r = Split(Replace(cell.Value, "،", ","), ",") For Each ky In r If CompareValues(tmp(ky), tmp(dataValue)) Then DrawCircle cell: Exit For Next ky End If Next cell End If Next col CleanUp: SetApp True Exit Sub SupApp: Resume ExitSub ExitSub: End Sub '""""""""""""""""""""""""""""" Private Function tmp(ByVal txt As String) As String tmp = Replace(Replace(Trim(txt), " ", " "), "ال", "") End Function '"""""""""""""""""""""""""""" Private Function CompareValues(value1 As String, value2 As String) As Boolean CompareValues = (InStr(1, value1, value2, vbTextCompare) > 0 Or InStr(1, value2, value1, vbTextCompare) > 0) End Function '""""""""""""""""""""""""""""""""""""""""" Private Sub DrawCircle(cell As Range) With cell.Worksheet.Shapes.AddShape(msoShapeOval, _ cell.Left + (cell.Width - xlength) / 2, _ cell.Top + (cell.Height - xWidth) / 2, _ xlength, xWidth) .Fill.Visible = msoFalse .Line.ForeColor.RGB = RGB(255, 0, 0) .Line.Weight = 1.5 .Name = "Oval_" & cell.Address(False, False) End With 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 وفي حدث ورقة Menuf Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B1")) Is Nothing Then AddDrawCircles End If End Sub فورمة - V2.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

نعم أخي @نبا زيد يمكننا فعل دالك لاكن لدي إقتراح أعتقد أنه أفضل بدلا من تعديل الألوان مباشرة في الكود كل مرة يمكنك تحديد ألوان الخلفية ولون الخط بسهولة من داخل ورقة تمت إظافتها للملف بإسم الإعدادات كما هو موضح في الصورة التالية كل ما عليك فعله هو 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

إدن لنجرب هدا Option Explicit Sub Remplissez() On Error GoTo SupApp Const FontName As String = "Arial" Const ky As Long = 5: Const timeCol As Long = 4 Const colName As Long = 2: Const iRow As Long = 7 Const xCOLOR As Long = 42495: Const lastCol As Long = 34 Dim lastRow As Long, i As Long, col As Long, r As Long, n As Long Dim tmps As Boolean, xWeekend As Boolean, sDate As Date, cnt As Date Dim key As String, sName As String, dayName As String, status As String Dim OnRng As Variant, rng As Variant, cnts As Variant, tmp As Object, j As Object Dim Icon As String, xAbsen As String, name As String, sTime As String, a As Range Icon = ChrW(&H2705): xAbsen = ChrW(&H274C) Dim dest As Worksheet: Set dest = Sheets("الاستمارة") Dim CrWS As Worksheet: Set CrWS = Sheets("التواريخ") lastRow = dest.Cells(dest.Rows.Count, 4).End(xlUp).Row Set tmp = CreateObject("Scripting.Dictionary") Set j = CreateObject("Scripting.Dictionary") With Application .ScreenUpdating = False: .Calculation = xlCalculationManual End With 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 End If Next For r = 4 To CrWS.Cells(CrWS.Rows.Count, 5).End(xlUp).Row If CrWS.Cells(r, 5).Value <> "" Then name = Trim(CrWS.Cells(r, 5).Value) sDate = CrWS.Cells(r, 6).Value sTime = Trim(CrWS.Cells(r, 9).Value) status = Trim(CrWS.Cells(r, 7).Value) key = name & "|" & CLng(sDate) & "|" & sTime j(key) = status If sTime = "صباحي/مسائي" Then j(name & "|" & CLng(sDate) & "|صباحي") = status j(name & "|" & CLng(sDate) & "|مسائي") = status End If End If Next OnRng = dest.Range(dest.Cells(iRow, 1), dest.Cells(lastRow, lastCol)).Value cnts = dest.Range(dest.Cells(ky, 5), dest.Cells(ky, lastCol)).Value rng = dest.Range(dest.Cells(ky + 1, 5), dest.Cells(ky + 1, lastCol)).Value For i = 1 To UBound(OnRng, 1) If Trim(OnRng(i, colName)) <> "" Then sName = Trim(OnRng(i, colName)) For col = 5 To lastCol n = col - 4 If IsDate(cnts(1, n)) Then cnt = cnts(1, n): dayName = rng(1, n) tmps = tmp.exists(CLng(cnt)) xWeekend = (dayName = "الجمعة" Or dayName = "السبت") sTime = Trim(OnRng(i, timeCol)) key = sName & "|" & CLng(cnt) & "|" & sTime status = IIf(j.exists(key), j(key), "") If tmps Or xWeekend Or status = "غائب" Or status = "مجاز" Or status = "متأخر" Then OnRng(i, col) = xAbsen Else OnRng(i, col) = Icon End If End If Next col Next i dest.Range(dest.Cells(iRow, 1), dest.Cells(lastRow, lastCol)).Value = OnRng With dest.Range(dest.Cells(iRow, 5), dest.Cells(lastRow, lastCol)) .Font.name = FontName: .Font.Bold = True .Interior.ColorIndex = -4142: .Font.Color = vbGreen For Each a In .Cells If a.Value = xAbsen Then a.Font.Color = vbRed a.Interior.Color = xCOLOR End If Next a End With With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With MsgBox "تم التحديث البيانات بنجاح", vbInformation Exit Sub SupApp: With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub استمارة-بعض النتائج المطلوبة v2.xlsb

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

عدل هنا تنسيق التاريخ بما يناسبك For i = 1 To OnRng For j = 0 To UBound(colVisu) cnt(i, j + 1) = TblBD(i, colVisu(j)) تنسيق التاريخ If IsDate(cnt(i, j + 1)) Then cnt(i, j + 1) = Format(cnt(i, j + 1), "dd/mm/yy") <=========== Next j Next i الى If IsDate(cnt(i, j + 1)) Then cnt(i, j + 1) = Format(cnt(i, j + 1), "dd/mm/yyyy")

تفضل جرب هدا 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

وعليكم السلام ورحمة الله تعالى وبركاته بعد معاينة الملف لاحظت وجود أرقام بتنسيقات مختلفة هل تقصد تحويلها الى العربية مثلا ٨-٣ = 3-8 ٢/٣ = 2/3 ٢٣ = 23 ١٦/٠٤/٢٠٢٥ = 16/04/2025

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

السلام عليكم ورحمة الله تعالى وبركاته أعتذر على التأخير في الرد فقد كنت في إجازة كما ذكرت سابقا 😃 بعد محاولتي المتواضعة لتعديل الملف أتمنى أن أكون قد وفقت في فهم طلبك وتنفيذه بالشكل المطلوب أعتذر أيضا على الإطالة لكن كان من الضروري توضيح بعض النقاط المهمة التي تم إدراجها في الملف حتى تتمكن من التعامل معه بسلاسة وتعديله لاحقا بما يتناسب مع احتياجاتك 1) بناء على طلبك تم تعديل طريقة جلب البيانات بحيث تعتمد الآن على نطاق A:U، وتم حذف الجدول السابق كما تم عرض جميع الأعمدة على ListBox التي تحتوي على 21 عمود Set WsRng = WS.Range("A2:U" & WS.Cells(WS.Rows.Count, 2).End(xlUp).row) 2) بما أنك طلبت إضافة اسم المستخدم وتاريخ التعديل أو الحذف لغرض المتابعة فهذا يعني أن الملف سيستخدم من قبل أكثر من مستخدم لذلك تم تعديل شاشة تسجيل الدخول الخاصة بالمستخدمين لتتناسب مع دالك عبر إنشاء ورقة جديدة باسم "Users" والتي ستكون مرئية فقط لمسؤول النظام (Admin) من خلالها يمكنك تحديد أسماء المستخدمين وكلمات المرور الخاصة بهم بما يتناسب مع احتياجاتك بعد كل عملية دخول سيتم إظافة إسم المستخدم ووقت الدخول في نفس الورقة على الأعمدة J:K 3) تمت إضافة ورقة خاصة لتتبع جميع التعديلات التي تطرأ على الملف بحيث توضح: القيم السابقة / القيم الجديدة / تاريخ التعديل / واسم المستخدم الذي قام بالعملية كما هو موضّح في الصورة أدناه 4) تمت إضافة ورقة خاصة بالمحذوفات وذلك استجابة لطلبك بالاحتفاظ بجميع البيانات التي يتم حذفها تحتوي هذه الورقة على معلومات تفصيلية تشمل: البيانات المحذوفة / اسم المستخدم الذي قام بالحذف / وتاريخ العملية تجدر الإشارة إلى أن كل من: ورقة التعديلات / ورقة المحذوفات / بطاقة الموظف ستكون مخفية عن المستخدمين العاديين ولن تكون مرئية إلا لمسؤول النظام (Admin) فقط وذلك لضمان سرية البيانات وحمايتها من التعديل أو الحذف غير المصرح به نظرا أن نطاق البيانات كبير يمكنك فتح (UserForm) عبر الضغط مرتين على أي خلية في الصف الأول 6) إمكانية إضافة صورة الموظف من أي مكان على الجهاز حسب اختيارك دون التقيد بمسار محدد الصيغ المسموح بها: JPG- JPEG- PNG- BMP- GIF 7) ترحيل بيانات الموظف مع ضمان عدم تكرار الرقم الوطني: في حال وجود رقم وطني مكرر يتم تنبيه المستخدم عند نجاح الترحيل تضاف البيانات ويتم تسطيرها تلقائيا وإظافة التسلسل على عمود A كما طلبت يتم إنشاء مجلد رئيسي باسم "المرفقات" (في حال لم يكن موجودا) وبداخله مجلد فرعي يحمل الرقم الوطني للموظف وتحفظ الصورة داخله (في حال تم اختيار صورة) وقد تم تنفيد نفس الفكرة بالنسبة لملفات PDF 😎 عند تعديل بيانات الموظف: يتم تحديث البيانات (بما في ذلك الصورة إذا تم تغييرها) يتم ترحيل البيانات السابقة والجديدة إلى ورقة التعديلات لتوثيق التغييرات 9) حذف بيانات الموظف: يتم حذف كافة بياناته من قاعدة البيانات كما يتم حذف المرفقات الخاصة به (سواء كانت صورا أو ملفات PDF) من المجلد الخاص به داخل "المرفقات" تحديث التسلسل 10) معاينة المرفقات بسهولة: يمكنك معاينة صورة الموظف مباشرة من ListBox بالنقر المزدوج (Double Click) إذا كانت الصورة مضافة مسبقا كما يمكنك فتح مجلد المرفقات بالكامل باستخدام زر مخصص (مجلد المرفقات) للاطلاع على جميع المجلدات و الملفات المتوفرة سواءا الصور أو بطائق PDF 11) حفظ تقرير PDF لبطاقة الموظف عند تحديده من قائمة الموظفين (ListBox) يتم إنشاء التقرير بصيغة PDF بمجرد تحديد الموظف من داخل LISTBOX (بناءا على الرقم الوطني) عمود E ويحفظ داخل مجلد خاص بإسم الموظف تم إظافة يوزرفورم جديد يمكنك من عرض ملفات PDF من خلاله التقرير يحتوي على جميع بيانات الموظف من العمود A إلى العمود U بطريقة منظمة وجاهزة للطباعة أو الحفظ ( يمكنك تعديله بما يناسبك) 12) حذف تلقائي لمرفقات الموظف عند حذف بياناته: في حال تم حذف الموظف من النظام يتم أيضا حذف بطاقة الموظف (PDF) الخاصة به تلقائيا إلى جانب المرفقات (الصورة أو ملفات أخرى) 13) تم تعويض معادلة دمج إسم الموظف الكامل بالأكواد مع تحديثها تلقائيا عند التعديل بالتوفيق............ للتجربة قم بنسخ المجلدات (تقارير الموظفين pdf + المرفقات ) بعد فك الظغط إلى نفس مسار المصنف وفي حال وجود أي استفسار- تعديل إضافي أو ملاحظات - سنكون دائما سعداء للمساعدة والتوضيح🌿 "لا تنسونا من صالح دعائكم – [أخوك في الله محمد هشام] قاعدة بيانات الموظفين .xlsm بيانات الموظفين v2.rar

اسف اخي على التأخير في الرد كنت في إجازة إن شاء الله سوف أحاول تعديل الملف وإعادة رفعه عن قريب بإدن الله

إتفاديا للتعديل أخي @Abaas يرجى ارفاق نفس الملف به مثال لشكل البيانات لديك على الملف الاصلي من النطاق A:U مع توضيح هل سيتم عرض جميع الأعمدة على الليست بوكس أي 21 عمود أو سيتم إظهار أعمدة معينة فقط لنتمكن من تحديد عرض الأعمدة و عدد Textbox المطلوب إظافتها بشكل دقيق

أخي لقد سبق تدكيرك بإرفاق ملفك ليس هدا مع بعض البيانات الوهمية للتوضيح عمود التسلسل - عمود وضع الصورة -شكل أسماء الفولدرات هل هي موجودة ام يتم إنشائها -عمود الموظف -اظافة ورقة المحذوفات- هل سيتم عرض جميع الأعمدة على الليست بوكس أو أعمدة معينة !!!! هده تفاصيل يجب توضيحها ضمن الملف الخاص بك بشكل دقيق لا يمكننا الإشتغال على التخمين فقط

تفضل جرب هدا لقد قمت بحدف مربعات النصوص الخاصة بعنوان المدرسة والسنة الدراسية وتعويضها بتنسيق الخلايا مباشرة يمكنك تعديلها بما يناسبك 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

العفو أخي الكريم يسعدنا أننا إستطعنا مساعدتك إليك طريقة أخرى مع إظافة التنسيقات يمكنك إختيار ما يناسبك Option Explicit Sub Extract_Names2() Dim dict As Object, ColA As Range, ColB As Range, a As Variant, b As Variant Dim tbl As String, Key As Variant, ColE As Long, début As Long, lr As Long, tmp As Range Dim dCount As Long, UniCount As Long, i As Long, Irow As Long, AutoFilterWasOn As Boolean Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With AutoFilterWasOn = CrWS.AutoFilterMode If AutoFilterWasOn Then CrWS.AutoFilterMode = False lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _ CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) With CrWS.Range("D2:E" & CrWS.Rows.Count) .ClearContents: .Borders.LineStyle = xlNone End With Set dict = CreateObject("Scripting.Dictionary"): dict.CompareMode = vbTextCompare Set ColA = CrWS.Range("A3:A" & lr): Set ColB = CrWS.Range("B3:B" & lr) For Each tmp In ColB tbl = tmp.Value If Not dict.exists(tbl) Then dict.Add tbl, 1 Else dict(tbl) = dict(tbl) + 1 Next tmp début = 3: dCount = 0 For Each tmp In ColA tbl = tmp.Value If dict.exists(tbl) Then CrWS.Cells(début, 4).Value = tbl CrWS.Cells(début, 5).Value = tbl dict.Remove tbl: début = début + 1: dCount = dCount + 1 End If Next tmp ColE = Application.WorksheetFunction.Max(début, CrWS.Cells(Rows.Count, 5).End(xlUp).Row + 1) UniCount = 0 For Each Key In dict.Keys CrWS.Cells(ColE, 5).Value = Key ColE = ColE + 1: UniCount = UniCount + 1 Next Key CrWS.Range("D2").Value = "عدد الوظائف المتشابهة: " & dCount & " | عدد الوظائف الفردية: " & UniCount CrWS.Columns("D:E").AutoFit On Error Resume Next CrWS.Range("D3:E" & CrWS.UsedRange.Rows.Count).FormatConditions.Delete On Error GoTo 0 With CrWS.Range("D3:E" & CrWS.UsedRange.Rows.Count) .FormatConditions.Add Type:=xlExpression, _ Formula1:="=AND(D3<>"""", COUNTIF($D$3:$E$" & .Rows.Count & ", D3)>1)" .FormatConditions(1).Font.Color = RGB(255, 0, 0): .FormatConditions(1).Interior.Color = RGB(255, 182, 193) End With Irow = Application.WorksheetFunction.Max( _ CrWS.Cells(CrWS.Rows.Count, "D").End(xlUp).Row, CrWS.Cells(CrWS.Rows.Count, "E").End(xlUp).Row) a = CrWS.Range("D3:D" & Irow).Value: b = CrWS.Range("E3:E" & Irow).Value For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then With CrWS.Cells(i + 2, 4).Borders .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic End With End If If b(i, 1) <> "" Then With CrWS.Cells(i + 2, 5).Borders .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic End With End If Next i With Application: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With End Sub Book2 v4.xlsb

يمكننا أخي تعديل الكود ليتناسب مع طلبك لاكن لاحظت انه هناك أسماء متشابهة الفرق الوحيد بينها هو المسافات كما في المثال الموضح في الصورة أسفله إدا كنت تعتبر أنها أسماء متشابهة يجب جلبها أمام بعضها البعض فالكود التالي ربما سيوفي بالغرض Option Explicit Sub Extract_Names() Dim dCount As Long, UniCount As Long, AutoFilterWasOn As Boolean Dim Ons As Object, tbl As String, dict As Object, _ début As Long, lr As Long, tmp As Range, Key As Variant Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With AutoFilterWasOn = CrWS.AutoFilterMode If AutoFilterWasOn Then CrWS.AutoFilterMode = False lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _ CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) Set dict = CreateObject("Scripting.Dictionary") dict.CompareMode = vbTextCompare Set Ons = CreateObject("Scripting.Dictionary") Ons.CompareMode = vbTextCompare For Each tmp In CrWS.Range("B3:B" & lr) If Not IsEmpty(tmp.Value) Then tbl = Replace(Trim(tmp.Value), " ", "") If Not dict.exists(tbl) Then dict.Add tbl, tmp.Row If Not Ons.exists(tbl) Then Ons.Add tbl, tmp.Row End If Next tmp CrWS.Range("D2:E" & CrWS.Rows.Count).ClearContents début = 3: dCount = 0: UniCount = 0 For Each tmp In CrWS.Range("A3:A" & lr) If Not IsEmpty(tmp.Value) Then tbl = Replace(Trim(tmp.Value), " ", "") If dict.exists(tbl) Then CrWS.Cells(début, 4).Value = tmp.Value CrWS.Cells(début, 5).Value = CrWS.Cells(dict(tbl), 2).Value dict.Remove tbl: Ons.Remove tbl: début = début + 1: dCount = dCount + 1 End If End If Next tmp For Each Key In Ons.keys CrWS.Cells(début, 5).Value = CrWS.Cells(Ons(Key), 2).Value début = début + 1: UniCount = UniCount + 1 Next Key CrWS.Range("D2").Value = "عدد الوظائف المتشابهة: " & dCount & " | عدد الوظائف الفردية: " & UniCount CrWS.Columns("D:E").AutoFit With Application: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With End Sub Book2 v3.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته أخي @M.Elmahmoudy رغم أن طلبك غير واضح تماما بالنسبة لي لاكن بعد معاينة الملف على حسب ما فهمت أعتقد أن الحل الأمثل لتنفيد طلبك هو إستخدام الأكواد لأنها سوف تضمن لك الدقة في النتائج والسرعة في التنفيد لأن المعادلات غير قادرة على تنفيذ جميع الوظائف بنفس الكفاءة خصوصا عند التعامل مع قوائم غير مرتبة وتكرار القيم ونطاقات غير المتساوية ولا ربما صفوف مخفية عند تنفيد الفرز على عمود معين زيادة على بطئ ملحوظ في الأداء عند وجود بيانات كبيرة يمكنك تجربة هدا وإذا كنت بحاجة إلى أي تعديلات إضافية يمكنني محاولة مساعدتك في ذلك Option Explicit Sub Extract_Names() Dim dict As Object, début As Long, lr As Long, tmp As Range, AutoFilterWasOn As Boolean Dim dCount As Long, UniCount As Long, ColA As Range, ColB As Range Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") With Application .ScreenUpdating = False: .Calculation = xlCalculationManual End With AutoFilterWasOn = CrWS.AutoFilterMode If AutoFilterWasOn Then CrWS.AutoFilterMode = False lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _ CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) Set dict = CreateObject("Scripting.Dictionary") Set ColA = CrWS.Range("A3:A" & lr): Set ColB = CrWS.Range("B3:B" & lr) For Each tmp In ColB If Not dict.exists(tmp.Value) Then dict.Add tmp.Value, tmp.Row Next tmp CrWS.Range("C2:C" & CrWS.Cells(CrWS.Rows.Count, 3).End(xlUp).Row).ClearContents début = 3: dCount = 0: UniCount = 0 For Each tmp In ColA If dict.exists(tmp.Value) Then CrWS.Cells(début, 3).Value = tmp.Value & " / " & CrWS.Cells(dict(tmp.Value), 2).Value dict.Remove tmp.Value début = début + 1 dCount = dCount + 1 End If Next tmp For Each tmp In ColB If dict.exists(tmp.Value) Then CrWS.Cells(début, 3).Value = tmp.Value début = début + 1 UniCount = UniCount + 1 End If Next tmp CrWS.Range("C2").Value = " عدد الوظائف / المتشابهة: " & dCount & " & الفردية: " & UniCount CrWS.Columns("C:C").EntireColumn.AutoFit Set dict = Nothing With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub Book2 v2.xlsb

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

تفضل جرب هدا Dim Sh As Boolean ' إسم المصنف الجديد Private Const WBname As String = "المجمع.xlsx" 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 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 tmps = 0 For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.Selected(i) Then tmps = tmps + 1 Next i If tmps = 0 And Not CheckBox1.Value Then MsgBox "الرجاء تحديد ورقة عمل واحدة على الأقل", vbExclamation, "إنتباه" Exit Sub End If Sh = True With Application .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False .CopyObjectsWithCells = False .Calculation = xlCalculationManual End With If Sh Then Set newWb = CreateWb() sPath = ThisWorkbook.path & "\" & WBname SaveNewWorkbook newWb, sPath sCount = 0 If CheckBox1.Value Then For i = 0 To Me.ListBox1.ListCount - 1 ShName = Me.ListBox1.List(i) CopySheetToNewWorkbook ThisWorkbook.Sheets(ShName), newWb shArr = shArr & ShName & vbNewLine sCount = sCount + 1 Next i Else For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.Selected(i) Then ShName = Me.ListBox1.List(i) CopySheetToNewWorkbook ThisWorkbook.Sheets(ShName), newWb shArr = shArr & ShName & vbNewLine sCount = sCount + 1 End If Next i End If WSDelete newWb newWb.Save newWb.Close SaveChanges:=True With Application .ScreenUpdating = True .EnableEvents = True .CopyObjectsWithCells = True .DisplayAlerts = True .Calculation = xlCalculationAutomatic End With Unload Me MsgBox IIf(sCount = 1, "تم حفظ الورقة بنجاح", "تم حفظ الأوراق بنجاح") & vbNewLine & vbNewLine & shArr, vbInformation End If End Sub Private Function CreateWb() As Workbook Dim newWb As Workbook Set newWb = Workbooks.Add(xlWBATWorksheet) newWb.Sheets(1).name = "New" Set CreateWb = newWb End Function Private Sub SaveNewWorkbook(ByVal newWb As Workbook, ByVal filePath As String) On Error Resume Next newWb.SaveAs fileName:=filePath, FileFormat:=xlOpenXMLWorkbook On Error GoTo 0 End Sub Private Sub CopySheetToNewWorkbook(ByVal sourceSheet As Worksheet, ByVal targetWorkbook As Workbook) sourceSheet.Copy After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count) Dim WS As Worksheet Set WS = targetWorkbook.Sheets(targetWorkbook.Sheets.Count) WS.UsedRange.Value = WS.UsedRange.Value Application.CutCopyMode = False End Sub Private Sub WSDelete(ByVal newWb As Workbook) On Error Resume Next newWb.Sheets("New").Delete On Error GoTo 0 End Sub تصدير صفحات v2.xlsm

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

رغم أن هدا لم يكن طلبك في أول مشاركة لاكنني أعتقد أنه الان قد تم تزويدك بجميع الحلول الممكنة للحصول على النتائج المطلوبة تم وضع الصيغ في جدول مستقل لتتمكن من مقارنة النتائج صيغ الأعمدة G + H =LET(extracted_text, IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2), NUMBERVALUE(IF(ISNUMBER(FIND(" ", extracted_text)), TRIM(LEFT(extracted_text, FIND(" ", extracted_text) - 1)), extracted_text))) أو =NUMBERVALUE(IF(ISNUMBER(FIND(" ", IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2))), TRIM(LEFT(IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2), FIND(" ", IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2)) - 1)), IF(ISNUMBER(FIND("-", E2)), TRIM(MID(E2, FIND("-", E2) + 1, LEN(E2) - FIND("-", E2))), E2)))) صيغ الأعمدة I + J =(IFERROR(VALUE("0 "&MID(F2,FIND(" ",F2)+1,LEN(F2)-FIND(" ",F2))), 0)) + (IFERROR(VALUE("0 "& IF(ISNUMBER(FIND(" ",G2)),TRIM(RIGHT(G2,LEN(G2)-FIND(" ",G2))), 0) ), 0)) بالتوفيق......... Sum Architect Units Feet-Inches V3.xlsx

العفو أخي يسعدنا أننا إستطعنا مساعدتك