تعديل كود

[بلانك]

اختلاف عرض العمود او الصف لاتتحرك الدوائر لتاخذ شكل وحجم الخلية

تعديل كود.xlsm

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

هذا يتطلب ببساطة تحديد حجم ثابت للدوائر  بدلا من حسابه بناء على حجم الخلايا

يمكنك تغيير هذه القيمة حسب الحجم الذي ترغب فيه   tmp = 10 

Option Explicit

Sub DrawCircles()
    Const SROW As Long = 6, EROW As Long = 10, SCOL As Long = 2, ECOL As Long = 9
    Dim ws As Worksheet, sColName As String, i As Long, j As Long, n As Long, tmp As Double
    Application.ScreenUpdating = False
    Call DelShap
    Set ws = ActiveSheet
    tmp = 10
    For i = SROW To EROW
        With ws
            n = .Range("k" & i).Value
            
            For j = ECOL To SCOL Step -1
                If .Range(.Cells(i, j).Address).Value <> Empty And n > 0 Then
                    sColName = Split(.Cells(1, j).Address, "$")(1)
                    
                    With ActiveSheet.Shapes.AddShape(msoShapeOval, _
                        .Range(sColName & i).Left + 0.5 * (.Range(sColName & i).Width - 2 * tmp), _
                        .Range(sColName & i).Top + 0.5 * (.Range(sColName & i).Height - 2 * tmp), _
                        2 * tmp, 2 * tmp)
                        .Line.Weight = 2
                        .Line.ForeColor.RGB = RGB(10, 10, 10)
                        .Fill.Visible = msoFalse
                    End With
                    n = n - 1
                End If
                If n = 0 Then Exit For
            Next j
        End With
    Next i
    
    Application.ScreenUpdating = True
End Sub

   

 

[بلانك]

بارك الله فيك وعلى الشرح البسيط