رسم دوائر

[عطية23]

ارجو المساعدة ان امكنرسم دوائر .xls

الملف المرفق المطلوب هو رسم دوائر على الحصص الاخيرة كل يوم من الايام الخمسة

عدد الدوائر المطلوب رسمها موجود بعمود عدد الدوائر وهذا العدد متغير فمثلاً الاحد مطلوي رسم 3 دوائر يمكن ان يتغير العدد ليصبح 2 او 4 او اي عدد اخر

[lionheart]

Try this code

Sub DrawCircles()
    Const SROW As Long = 7, EROW As Long = 11, SCOL As Long = 2, ECOL As Long = 10
    Dim ws As Worksheet, sColName As String, i As Long, j As Long, n As Long, rd As Double
    Application.ScreenUpdating = False
        Call RemoveCircles
        Set ws = ActiveSheet
        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
                        rd = 0.5 * Application.Min(.Cells(i, j).Height, .Cells(i, j).Width)
                        sColName = Split(.Cells(1, j).Address, "$")(1)
                        With ActiveSheet.Shapes.AddShape(msoShapeOval, Range(sColName & i).Left + 0.5 * (.Range(sColName & i).Width - 2 * rd), .Range(sColName & i).Top + 0.5 * (.Range(sColName & i).Height - 2 * rd), 2 * rd, 2 * rd)
                            .Line.Weight = 1.5
                            .Line.ForeColor.RGB = RGB(0, 0, 255)
                            .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

Private Sub RemoveCircles()
    Dim shp As shape
    For Each shp In ActiveSheet.Shapes
        If shp.AutoShapeType = msoShapeOval Then shp.Delete
    Next shp
End Sub

 

Const SROW As Long = 7, EROW As Long = 11, SCOL As Long = 2, ECOL As Long = 10

In this line you can specify the start row SROW & end row EROW & start column SCOL & end column ECOL

[عطية23]

جزيل الشكر ابداع من حضرتك

زادك الله بسطة في العلم

وجعلك عوناً لاخوتك اعضاء المنتدى