المطلوب كود وليس تنسيق شرطي لتلوين الخلايا الاقل من درجة النهاية الصغرى

[بلانك]

درجات طلبه.xlsx

[mohamed_omar]

محاولة متواضعة ارجوا ان تكون مفيدة

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim lr As Long
lr = sheet1.Range("a10000").End(xlUp).Row
For i = 4 To lr
If sheet1.Cells(i, 2).Value < sheet1.Range("b3") Then
 sheet1.Cells(i, 2).Interior.Color = vbRed
 Else
 sheet1.Cells(i, 2).Interior.Color = vbWhite
End If
Next
For i = 4 To lr
If sheet1.Cells(i, 3).Value < sheet1.Range("c3") Then
 sheet1.Cells(i, 3).Interior.Color = vbRed
 Else
 sheet1.Cells(i, 3).Interior.Color = vbWhite
End If
Next
For i = 4 To lr
If sheet1.Cells(i, 4).Value < sheet1.Range("d3") Then
 sheet1.Cells(i, 4).Interior.Color = vbRed
 Else
 sheet1.Cells(i, 4).Interior.Color = vbWhite
End If
Next
For i = 4 To lr
If sheet1.Cells(i, 5).Value < sheet1.Range("e3") Then
 sheet1.Cells(i, 5).Interior.Color = vbRed
 Else
 sheet1.Cells(i, 5).Interior.Color = vbWhite
End If
Next
End Sub

درجات طلبه.xlsm

[محي الدين ابو البشر]

mohamed_omar@

Sub test2()
    Dim i, ii As Long
    With Sheet1
    For i = 4 To .Range("a10000").End(xlUp).Row
        For ii = 1 To 4
            If .Cells(i, ii).Value < Sheet1.Cells(3, ii) Then
                .Cells(i, ii).Interior.Color = vbRed
            Else
                .Cells(i, ii).Interior.Color = vbWhite
            End If
        Next
    Next
    End With
End Sub

نفس الكود ولكن

[mohamed_omar]

بارك الله فيك استاذنا محي الدين

[محي الدين ابو البشر]

أو أذا أحببت أيضاً

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim i, ii As Long
 If Not Intersect(Target, Me.Range("A4:D" & Me.Range("a10000").End(xlUp).Row)) Is Nothing Then
            If Target.Value < Me.Cells(3, Target.Column) Then
                Target.Interior.Color = vbRed
            Else
               Target.Interior.Color = vbWhite
            End If
    End If
End Sub

 

[بلانك]

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