تلوين جدول

[بلانك]

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

جدول التفريغ.xlsm

[بلانك]

 Up

 

[بلانك]

Up 

[بلانك]

اين الردود من الاستاذه الأجلاء  ؟؟؟؟؟؟؟؟؟

[محمد هشام.]

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

ضع هدا في حدث ورقة معلمين

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 Call Coloring_Classes
    tmps = False
End Sub

Sub Coloring_Classes()
    Dim Sh As Worksheet: Set Sh = ThisWorkbook.Sheets(ShName)
    Dim Search As String, ColNames As Range, Rng As Long
    Dim OnRng As Range, tmp As Variant, r As Long, c As Long, a() As Long
    
    On Error GoTo SupApp
    With Application
        .ScreenUpdating = False: .EnableEvents = False
        .Calculation = xlCalculationManual

        Search = Sh.Range("D5").Value
        Set ColNames = Sh.Range("Q2:Q" & _
        Sh.Cells(Sh.Rows.Count, "Q").End(xlUp).Row).Find(Search, LookIn:=xlValues, LookAt:=xlWhole)

        If ColNames Is Nothing Then
            MsgBox Search & " " & "غير موجود", vbExclamation
            
            GoTo Cleanup
        End If

        Rng = ColNames.Offset(0, 1).Interior.Color

        Set OnRng = Sh.Range("C7:I11")
        tmp = OnRng.Value
        ReDim a(1 To UBound(tmp, 1), 1 To UBound(tmp, 2))

        For r = 1 To UBound(tmp, 1)
            For c = 1 To UBound(tmp, 2)
                If Len(tmp(r, c)) > 0 Then a(r, c) = Rng
            Next c
        Next r

        OnRng.Interior.Color = xlNone
        For r = 1 To UBound(a, 1)
            For c = 1 To UBound(a, 2)
                If a(r, c) <> 0 Then OnRng.Cells(r, c).Interior.Color = a(r, c)
            Next c
        Next r
    End With

Cleanup:
    Application.ScreenUpdating = True: Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub

SupApp:
    Resume Cleanup
End Sub

 

 

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

تم تعديل منذ 2 ساعات بواسطه محمد هشام.

[بلانك]

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

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

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

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

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