تعديل على كود وضع دوائر حمراء شهادات طلاب

[بلانك]

خطأ بالكود وضع دوائر حمرا ء على درجات اعلى من القيمة الصغرى انظر المرفق

test.rar

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

السلام عليكم 

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

Option Explicit

Sub CircleLowGrades()
    Dim ws As Worksheet
    Dim gradeRanges As Variant
    Dim maxRanges As Variant
    Dim cell As Range
    Dim maxCell As Range
    Dim maxGrade As Double
    Dim shp As Shape
    Dim i As Integer, j As Integer
    Dim gradeRange As Range, maxRange As Range

    Set ws = ThisWorkbook.Sheets("شهادةنصف")

    gradeRanges = Array(ws.Range("D13:P13"), ws.Range("D30:P30"), ws.Range("D47:P47"))
    maxRanges = Array(ws.Range("D12:P12"), ws.Range("D29:P29"), ws.Range("D46:P46"))

    For Each shp In ws.Shapes
        If shp.Name Like "Circle*" Then shp.delete
    Next shp

    For i = LBound(gradeRanges) To UBound(gradeRanges)
        Set gradeRange = gradeRanges(i)
        Set maxRange = maxRanges(i)

        For j = 1 To gradeRange.Cells.Count
            Set cell = gradeRange.Cells(j)
            Set maxCell = maxRange.Cells(j)
            
            If IsNumeric(maxCell.Value) Then
                maxGrade = Val(maxCell.Value)
            Else
                maxGrade = 0
            End If

            If IsNumeric(cell.Value) Then
                If Val(cell.Value) < maxGrade Then
                    Call DrawCircle(ws, cell)
                End If
            ElseIf cell.Value = "غ" Or cell.Value = "غـ" Or cell.Value = "صفر" Then
                Call DrawCircle(ws, cell)
            End If
        Next j
    Next i
End Sub

Sub DrawCircle(ws As Worksheet, cell As Range)
    Dim shp As Shape
    Set shp = ws.Shapes.AddShape(msoShapeOval, cell.Left + 2, cell.Top + 2, cell.Width - 4, cell.Height - 4)
    shp.Name = "Circle" & cell.Address(False, False)
    shp.Line.ForeColor.RGB = RGB(255, 0, 0)
    shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
    shp.Fill.Transparency = 1
End Sub

test1.xlsb

[بلانك]

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