طلب وضع دوائر حمراء في ورقة الكشف

[أبو العقاب]

السلام عليكم

في المرفق مثال فيه ورقة الكشف

أريد وضع دائرة حمراء حول معدّل المادة الراسبة علما بأن مادة الاجتماعيات النهاية الصغرى 100 وبقية المواد النهاية الصغرى 50

مع مراعاة !!!

1-أنه يوجد كشفين الأول فيه 25 اسم والبقية في كشف آخر أسفل منه

2-إذا كانت الخلية فارغة لا توضع الدائرة

الشهادات نهائي مع ترحيل وترتيب الأوائل2016.rar

[أبو العقاب]

??

[أبو العقاب]

طبقت أحد الأكواد ولكنه ينفّذ في الكشف الأدنى ولا ينفذ في الكشف الأعلى

لو أحد الأخوة يعدّل لنا الكود

الكود هو 

Sub DrawRedCircles()
    Dim myArray     As Variant
    Dim Rng         As Range
    Dim Cel         As Range
    Dim Cell        As Range
    Dim L           As Long
    Dim T           As Long
    Dim W           As Long
    Dim H           As Long
    Dim X           As Long
    Dim rRow        As Long
    Dim startRow    As Long

    ãÕÝæÝÉ ÈÃÓãÇÁ ÇáÃÚãÏÉ ÇáãÑÇÏ æÖÚ ÏæÇÆÑ ÍãÑÇÁ ÈåÇ
    myArray = Array("j", "m", "p", "s", "v", "y", "ab", "ae", "ah", "ak")

    ÑÞã ÇáÕÝ ÇáÐí íÍÊæí Úáì ÏÑÌÇÊ ÇáäåÇíÉ ÇáÕÛÑì
    rRow = 17

    ÕÝ ÇáÈÏÇíÉ Ãí Ãæá ÕÝ Èå ÏÑÌÇÊ ÇáØáÇÈ
    startRow = 18

    Application.ScreenUpdating = False
        Call RemoveCircles
        
        With Sheets("ÇáßÔÝ")
            For X = LBound(myArray) To UBound(myArray)
                Set Cel = Range(myArray(X) & rRow)
                Set Rng = Range(myArray(X) & startRow, Range(myArray(X) & startRow).End(xlDown))
    
                For Each Cell In Rng
                    If Cell.Value < Cel Or Cell.Value = "Û" Then
                        L = Cell.Left: T = Cell.top
                        W = Cell.Width: H = Cell.Height
    
                        With ActiveSheet.Shapes.AddShape(msoShapeOval, L, T, W, H)
                            .Fill.Visible = msoFalse
                            .Line.ForeColor.RGB = RGB(255, 0, 0)
                            .Line.Transparency = 0
                            .Line.Weight = 1.5
                        End With
                    End If
                Next Cell
            Next X
        End With
    Application.ScreenUpdating = True
    
    
   
  
    ãÕÝæÝÉ ÈÃÓãÇÁ ÇáÃÚãÏÉ ÇáãÑÇÏ æÖÚ ÏæÇÆÑ ÍãÑÇÁ ÈåÇ
    myArray = Array("j", "m", "p", "s", "v", "y", "ab", "ae", "ah", "ak")

    ÑÞã ÇáÕÝ ÇáÐí íÍÊæí Úáì ÏÑÌÇÊ ÇáäåÇíÉ ÇáÕÛÑì
    rRow = 67

    ÕÝ ÇáÈÏÇíÉ Ãí Ãæá ÕÝ Èå ÏÑÌÇÊ ÇáØáÇÈ
    startRow = 68

    Application.ScreenUpdating = False
        Call RemoveCircles
        
        With Sheets("ÇáßÔÝ")
            For X = LBound(myArray) To UBound(myArray)
                Set Cel = Range(myArray(X) & rRow)
                Set Rng = Range(myArray(X) & startRow, Range(myArray(X) & startRow).End(xlDown))
    
                For Each Cell In Rng
                    If Cell.Value < Cel Or Cell.Value = "Û" Then
                        L = Cell.Left: T = Cell.top
                        W = Cell.Width: H = Cell.Height
    
                        With ActiveSheet.Shapes.AddShape(msoShapeOval, L, T, W, H)
                            .Fill.Visible = msoFalse
                            .Line.ForeColor.RGB = RGB(255, 0, 0)
                            .Line.Transparency = 0
                            .Line.Weight = 1.5
                        End With
                    End If
                Next Cell
            Next X
        End With
    Application.ScreenUpdating = True
End Sub

تم تعديل أغسطس 14, 2016 بواسطه أبو العقاب