كود لعمل ايقونه صح واكس حسب كل حالة

[نبا زيد]

السلام عليكم

محتاج كود لعمل ايقونة (صح) عدا ايام الجمعة والسبت والعطل وحالات المجاز والغائب والمتاخر تكون ايقونة اكس

جزيتم خير

 

 

استمارة.xlsx

تم تعديل الخميس at 14:15 بواسطه نبا زيد

[محمد هشام.]

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

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

 

 

[نبا زيد]

تمام

ملف يوضح النتائج المطلوبة

 

استمارة-بعض النتائج المطلوبة.xlsx

[محمد هشام.]

إدن لنجرب هدا

 

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

[نبا زيد]

الله يرضى عليك

وزادتك من علمه وفضله

تسلم

تمام 100 %

مشكور

[نبا زيد]

السلام عليكم

ممكن جعل المجاز لون  - والعائب لون - والمتاخر لون  - الوان مختلفة - العطل - لونه ممتاز

وتغيير لون علامة صح الى ( الخلفية بيضاء - والعلامة اسود )

لسهول التمييز

جزيت خيرا

[محمد هشام.]

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

 

كل ما عليك فعله هو

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