تعديل كود الدوائر الحمراء

[علي بطيخ سالم]

هل يمكن تعديل هذا الكود لإعطاءه درجة صغرى يعتمد عليها في الدوائر الحمراء لكل عمود لأن الدرجات متفاوتة في كل مرة وكيف لي أن أجعل لون الدوائر أسود بدلاً من أحمر

Sub Circles()
'åÐÇ ÇáßæÏ ááãÍÊÑã ÇáäÇÈÛå ÒíÒæ ÇáÚÌæÒ
'ÇáåÏÝ ãä ÇáßæÏ åæ æÖÚ ÏæÇÆÑ Úáì ÏÑÌÇÊ  Ýí ÇÚãÏå ãÚíäå
'Êã åÐÇ ÇáßæÏ Ýí 19/5/2017

'ÇÓÊÏÚÇÁ ßæÏ ÇáãÓÍ ÇæáÇ
Call DeletingShp

'ãÊÛíÑÇÊ
Dim ws As Worksheet
Dim Arr() As Variant
Dim LR As Long, R As Long, i As Long
Dim Cel As Range

'ÇÓã ÕÝÍå ÇáÚãá
Set ws = Sheets("ÔíÊ")

  ' åÐÇ ÔÑØ ÇáÇ íÚãá ÇáßæÏ ÞÈá ÇáÕÝ 14
If LR < 14 Then LR = 14

'ãÊÛíÑ áÚÏ ÇáÕÝæÝ
LR = ws.Range("C" & Rows.Count).End(xlUp).Row

'ÇÑÞÇã ÇáÇÚãÏå ÇáãØáæÈ æÖÚ ÏæÇÆÑ ÝíåÇ
Arr = Array(11, 12, 14, 15, 17, 18, 20, 21, 23, 24, 26, 27, 29, 30, 32, 33, 35, 36, 37)

'ÈÏÇíå ÇáÕÝæÝ
For R = 14 To LR

  ' ÚÑÖ ÇáãÕÝæÝÉ ÇáÎÇÕÉ ÈÇáÇÚãÏÉ
For i = LBound(Arr) To UBound(Arr)

  ' äØÇÞ ÊØÈíÞ ÇáÇãÑ æåæ ÇáÎÇÕ ÈÑÓã ÇáÏæÇÆÑ
For Each Cel In ws.Cells(R, Arr(i))

  '  ÇáÔÑØ ÇáÐì Úáì ÇÓÇÓå ÓæÝ íÊã ÑÓã ÇáÏæÇÆÑ
If Cel.Value < ws.Cells(4, Cel.Column) Or Cel.Value = "Û" Then

  ' ãæÇÕÝÇÊ ÇáÔßá æåæ åäÇ ÚÈÇÑÉ Úä ÏÇÆÑÉ æãÇ Èíä ÇáÇÞæÇÓ åæ ÇÈÚÇÏ ÇáÏÇÆÑÉ ÍÊì áÇ ÊÕÈÍ ÇßÈÑ ãä ÍÌã ÇáÎáíÉ
Set xx = ActiveSheet.Shapes.AddShape(msoShapeOval, Cel.Left, Cel.Top, Cel.Width, Cel.Height)

  ' ãæÇÕÝÇÊ ÇáÏÇÆÑÉ ãä ÍíË ÏÑÌÉ Çááæä æÍÌã ÇáÎØ æ ÇáÔÝÇÝíÉ
xx.Fill.Visible = msoFalse
xx.Line.ForeColor.SchemeColor = 10
xx.Line.Weight = 1.2
  End If
 Next
  Next
   Next
End Sub

  '    ÇáßæÏ ÇáËÇäì
Sub DeletingShp()

   ''  ÇáãÊÛíÑÇÊ
    Dim shp As Shape, x As Long
    
     ' åÐÇ ÇáäØÇÞ íÓãÍ ÈãÓÍ ßá ÇáÇÔßÇá Ýì æÑÞÉ ÇáÚãá ÓæÇÁ ÏÇÆÑÉ Çæ ÛíÑåÇ
    For Each shp In ActiveSheet.Shapes
    
   '   ÇãÑ ÇáãÓÍ
      If shp.Type = 1 Then shp.Delete: x = x + 1
    Next shp
   '    ÑÓÇáÉ ÈÚÏÏ ÇáÏæÇÆÑ ÇáÊì Êã ãÓÍåÇ
'MsgBox "Êã ÍÐÝ   " & x & "   ÏÇÆÑÉ ÈäÌÇÍ", vbMsgBoxRight, "ÇáÍãÏááå"
End Sub

 

[أحمد يوسف]

أستاذى الكريم علي الأفضل ان تقوم برفع الملف حتى تتمكن من تلقى المساعدة كاملة وانتباه الأساتذة لك

جزاك الله كل خير