دوائر حمراء

[عطية23]

الملف المرفق به كود لوضع الدوائر لكن الكود لا يعمل هل اجد عندكم حل ولكم جيل الشكر

وضع دوائر حول الحصص.xls

[lionheart]

Try this modification

Option Explicit

Sub Draw_Circles()
    Const nMax As Integer = 30
    Dim mx, ws As Worksheet, v As Shape, x As Integer, r As Long, c As Long, cnt As Long
    Call Remove_Circles
    x = ActiveWindow.Zoom
    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Worksheets("ty")
    ActiveWindow.Zoom = 100
    mx = ws.Range("N2").Value
    If mx = 0 Or Not IsNumeric(mx) Then MsgBox "Enter Valid Number In Cell N2", vbExclamation: GoTo Skipper
    For c = 10 To 8 Step -1
        For r = 4 To 14 Step 2
            With ws.Cells(r, c)
                If .Value <> "" Then
                    cnt = cnt + 1
                    Set v = .Parent.Shapes.AddShape(msoShapeOval, .Left + 1, .Top + 1, .Width - 2, .Height - 2)
                    v.Fill.Visible = msoFalse
                    v.Line.ForeColor.SchemeColor = 10
                    v.Line.Weight = 1
                    If cnt = mx Then Exit For
                End If
            End With
        Next r
        If cnt = mx Then Exit For
    Next c
    cnt = 0
    For c = 2 To 10
        For r = 20 To 30 Step 2
            With ws.Cells(r, c)
                If .Value <> "" Then
                    cnt = cnt + 1
                    Set v = .Parent.Shapes.AddShape(msoShapeOval, .Left + 1, .Top + 1, .Width - 2, .Height - 2)
                    v.Fill.Visible = msoFalse
                    v.Line.ForeColor.SchemeColor = 10
                    v.Line.Weight = 1
                    If cnt = nMax Then Exit For
                End If
            End With
        Next r
        If cnt = nMax Then Exit For
    Next c
Skipper:
    ActiveWindow.Zoom = x
    Application.ScreenUpdating = True
    MsgBox "Done...", 64
End Sub

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

 

[عطية23]

مشكور استاذنا العزيز قلب الاسد

لكن المطلوب الكود يعمل على جدول واحد فقط اي يضع الدوائر في جدول واحد فقط من بداية يوم الاحد حتى يوم الخميس ولو امكن يكون الدوائر لو كان المطلوب 9 دوائر الاحد 2 الاثنين 2 الثلاثاء 2 الاربعاء 2 الخميس 1 وهكذا ايا كان العدد المطلوب واسف على كثرة الطلبات ولكن عشمنا كبير والله يعنكم ويصبركم علينا

[lionheart]

The code works on both tables on my side

[عطية23]

استاذى العزيز المطلوب انه يعمل على جدول واحد فقط

we need to work on one table

مع جزيل الشكر

ولو ممكن باقى الطلبات جاكم الله خيراً