mrwaelhistory

بارك الله فيك

جزاك الله خيرا أستاذ خبور الخير

جميل جدا

بارك الله فيك و نرجو المزيد لنستفيد

- بعمل ماكرو بهذا الكود :

Sub sDrawOval()

If TypeName(Selection) <> "Range" Then Exit Sub

Dim ssRange As Range

Set ssRange = Selection

DrawOvals ssRange, 60, 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

2 -بإضافة تلك الدالة :

=fDrawOval(B2:J20;60;0.2)

حيث 60 الحد الأدنى

0.2 هى نسبة الهامش المتروك بين القطع وحدود الخلية

ويمكن تغيير الرقم " 60 " كيفما شئت حسب الحد الأدنى للخلية ،وتغيير النطاق B2:J20 أيضاً

لاحظ أن : تلك الدالة توضع فى خلية فى هامش الصفحة .