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

[نبا زيد]

السلام عليكم

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

جزيتم خير

 

 

استمارة.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 %

مشكور

[نبا زيد]

السلام عليكم

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

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

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

جزيت خيرا