صحيح اخى الكريم ولكنها لا تظهر فى الطباعة ولا تحفظ
Option Explicit
Option Base 1
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("Q", "U", "Z", "AD", "AI", "AM", "AS", "AT", "AU", "AY", "BE", "BF", "BG", "BK", "BN", "BQ", "BR", "BW", "CA", "CG", "CH", "CI", "CM", "CR", "CV")
'رقم الصف الذى يحتوى على الدرجات النهائية الصغرى
rRow = 9
'صف البداية أى أول صف به درجات الطلاب
startRow = 10
Application.ScreenUpdating = False
Call RemoveCircles
With Sheets("Sheet1")
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 .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