تلوين جدول

[بلانك]

المطلوب بدخل الملف في ورقتبن (جدول- معلمين) وعذرا فقد طرحت الموضوع هذا مسبقا ولكن طلب هذا الموضع بهذا الشكل .... فسامحوني

جدول التفريغ.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

تم تعديل April 28 بواسطه محمد هشام.

[بلانك]

شكرا على الرد استاذي محمد بيك هشام ... ولكن هناك ثلاث جداول  يتم تظليل الجدول الاول فقط لاحظ الصورة المرفقة

[عبدالله بشير عبدالله]

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

جرب التعديل التالي

جدول التفريغ V2 (1).xlsm

 

[محمد هشام.]

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

اما بخصوص ورقة جدول  

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

تم تعديل April 28 بواسطه محمد هشام.

[بلانك]

بارك الله فيكما استاذي /محمد بيك هشام .واستاذي / عبدالله بيك بشير على المساعدة وجعله في ميزان حسناتكم