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 أيضاً لاحظ أن : تلك الدالة توضع فى خلية فى هامش الصفحة .