محمد هشام.

إثراءا للموضوع يمكنك توسيع منع التكرار على عدة أعمدة مثلا A - C - E Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, OnRng As Range, Cell As Range Dim ColArr As Variant, tmp As Long On Error GoTo CleanExit Application.EnableEvents = False ColArr = Array("A", "C", "E") ' ColArr = Array("A") For i = LBound(ColArr) To UBound(ColArr) If Not Intersect(Target, Me.Range(ColArr(i) & "2:" & ColArr(i) & Me.Rows.Count)) Is Nothing Then Set OnRng = Me.Columns(ColArr(i)) For Each Cell In Intersect(Target, OnRng) If Trim(Cell.Value) <> "" Then tmp = Application.WorksheetFunction.CountIf(OnRng, Cell.Value) If tmp > 1 Then Cell.ClearContents End If End If Next Cell End If Next i CleanExit: Application.EnableEvents = True End Sub

وعليكم السلام ورحمة الله تعالى وبركاته هل ترغب بإستخدام الأكواد ؟ ادا كان هدا يناسبك ضع هدا في حدث الورقة 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 Const OnRng As String = "B6:AJ23" Private Const début As Long = 5 Private Const lastCol As Long = 36 Private Const linge As Long = 2 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(OnRng).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 = début 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 = début To ColA If tmps.exists(Sh.Cells(r, "A").Value) Then For c = linge To lastCol 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 جدول التفريغ V3.xlsm

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

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

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