,وضع دائرة على درجة التلميذ ( الماكرو)

 

Sub sDrawOval()
If TypeName(Selection) <> "Range" Then Exit Sub
Dim ssRange As Range
Set ssRange = Selection
DrawOvals ssRange, 9, 0.2
End Sub
Function fDrawOval(ByVal fRange As Range, MinDegree As Single, MarginRatio As Single) As String
Application.Volatile
DrawOvals fRange, MinDegree, MarginRatio
fDrawOval = ""
End Function
Function DrawOvals(sRange As Range, MinDegree As Single, OvMargRatio As Single)
Dim cCell As Range
Dim shShape As Shape
Dim OvName As String, OvSheet As String
On Error GoTo DR_OVAL_Err
For Each cCell In sRange
OvName = "oval" + cCell.AddressLocal
OvSheet = cCell.Worksheet.Name
If IsExistShape(OvName, OvSheet) Then
      If cCell.Value >= MinDegree Or cCell.Formula = "" Then
        cCell.Worksheet.Shapes(OvName).Delete
      End If
Else
 
If cCell.Value < MinDegree And cCell.Formula <> "" Then
  MrH = OvMargRatio * cCell.Height
  MrW = OvMargRatio * cCell.Width
  OvalW = cCell.Width - MrW
  OvalH = cCell.Height - MrH
  Set shShape = cCell.Worksheet.Shapes.AddShape(msoShapeOval, cCell.Left + MrW / 2, cCell.Top + MrH / 2, OvalW, OvalH)
    With shShape
      .Name = OvName
      .Fill.Transparency = 1#
      .Fill.Visible = msoFalse
      .Line.ForeColor.RGB = RGB(255, 0, 0)
      .Line.Weight = 1.25
    End With
  End If
 End If
Next
Set cCell = Nothing
Exit Function
DR_OVAL_Err:
MsgBox Err & " : " & Error
Err.Clear
Resume Next
End Function
Function IsExistShape(ShapeName As String, SheetName As String) As Boolean
Dim shShape As Shape
IsExistShape = False
For Each shShape In ThisWorkbook.Worksheets(SheetName).Shapes
If shShape.Name = ShapeName Then
 IsExistShape = True
Exit Function
End If
Next shShape
End Function

=fDrawOval(B2:B20;9;0.2)