مطلوب كود لاستدعاء درجات المادة وتحويلها إلى ألوان

[سيد الأكـرت]

السلام عليكم ورحمة الله وبركاته إخوتي في الله مطلوب مساعدة في الملف المرفق بكود يقوم باستدعاء درجات المادة المختارة من القائمة المنسدلة وتحويلها إلى ألوان طبقا للتنسيق الشرطي الاتي الدرجة 1 اللون احمر الدرجة 2 اللون اصفر الدرجة 3 اللون اخضر الدرجة 4 اللون ازرق 

تقييمات.xlsx

[سيد الأكـرت]

طب ممكن الكود باستدعاء الدرجات فقط حسب المادة 

[محمد هشام.]

صراحة لم افهم المطلوب جيدا .

تم تعديل مايو 26, 2023 بواسطه Mohamed Hicham

[lionheart]

Insert Module1 and paste the following code

Option Explicit

Private Sub ColorBySubject()
    Const STARTROW As Long = 8, STARTCOL As Long = 5, COLSNUM As Long = 4
    Dim x, aCols, wsMarks As Worksheet, wsColors As Worksheet, rng As Range, sMarks As String, sQuote As String, sCell As String, n As Long, m As Long, ii As Long
    Application.ScreenUpdating = False
        With ThisWorkbook
            Set wsMarks = .Worksheets(1)
            Set wsColors = .Worksheets(2)
        End With
        Set rng = wsColors.Range("S8:S15")
        x = Application.Match(wsColors.Range("E3").Value, rng, 0)
        If Not IsError(x) Then
            sMarks = wsMarks.Name
            sQuote = WorksheetFunction.Rept(Chr(34), 2)
            n = wsMarks.Cells(Rows.Count, "C").End(xlUp).Row - 3
            aCols = Array(5, 8, 11, 14, 17, 20, 23, 26)
            For m = 1 To 3
                sCell = ColumnToLetter(aCols(x - 1) + m - 1) & "4"
                With wsColors
                    If m <> 3 Then
                        For ii = 4 To 1 Step -1
                            With .Cells(STARTROW, m * COLSNUM - ii + STARTCOL).Resize(n)
                                .Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & "=" & ii & ",""0""," & sQuote & "))"
                            End With
                        Next ii
                    Else
                        With .Cells(STARTROW, 13).Resize(n)
                            .Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & ">=3.5,""0""," & sQuote & "))"
                            .Offset(, 1).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(AND(" & sMarks & "!" & sCell & ">=2.5," & sMarks & "!" & sCell & "<3.5),""0""," & sQuote & "))"
                            .Offset(, 2).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(AND(" & sMarks & "!" & sCell & ">1," & sMarks & "!" & sCell & "<2.5),""0""," & sQuote & "))"
                            .Offset(, 3).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & "=1,""0""," & sQuote & "))"
                        End With
                    End If
                End With
            Next m
        End If
    Application.ScreenUpdating = True
End Sub

Function ColumnToLetter(ByVal columnNumber As Long) As String
    If columnNumber < 1 Then Exit Function
    ColumnToLetter = UCase(ColumnToLetter(Int((columnNumber - 1) / 26)) & Chr(((columnNumber - 1) Mod 26) + Asc("A")))
End Function

 

Then in worksheet module (Colors) [The worksheet that has the data validation list], paste the following code

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Target.Address = "$E$3" Then
        Application.Run "Module1.ColorBySubject"
    End If
End Sub

 

[سيد الأكـرت]

استاذنا الفاضل lionheart

شكرا جزيلا لحضرتك الكود يعمل بامتياز جزاك الله خيرا وانا عاجز عن الشكر