هل يمكن عمل ذلك بالكود ؟؟؟

بلانك · منذ 7 ساعات

المطلوب بدخل الملف في ورقتبن (جدول- معلمين)

**محمد هشام.** · منذ 5 ساعات

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

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

1016604892_.PNG.8f29bb5cfefa23e3c7dc978f9cee9f64.PNG