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

[بلانك]

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

جدول.xlsm

[محمد هشام.]

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

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

 

جدول.xlsm

[بلانك]

بارك الله فيك وجعلك عونا للاخرين ............... ولكن! الورقة الثانية وهي جدول المعلمين لم يتم عمل لها كود . اطمع منك عمل كود لها وأسف على تعب حضرتك

تم تعديل April 26 بواسطه بلانك

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

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

بعد اذن معلمنا واستاذنا محمد هشام

جدول2.xlsm

[بلانك]

بارك الله فيك استاذنا عبدالله بشير وبارك في هذا المنتدى العظيم لما استفدناه من خبراء هذا المنتدى . والشكر موصول بعد إذن الاستاذ عبدالله لاستاذنا / محمد بيك هشام

[محمد هشام.]

8 ساعات مضت, بلانك said:

ارك الله فيك وجعلك عونا للاخرين ............... ولكن! الورقة الثانية وهي جدول المعلمين لم يتم عمل لها كود . اطمع منك عمل كود لها وأسف على تعب حضرتك

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

بالتوفبق 

 

[بلانك]

جل من لا يسهو وشكرا للمرة المليون من لم يشكر الناس فلم يشكر الله