كود اضافة الدوائر الحمرا ويعمل بطريقة فريده

[ناصر سعيد]

كود اضافة الدوائر الحمرا ويعمل بطريقة فريده

يمكنك استخدام تكبير او تصغير العرض بدون التاثير في وضع الدوائر في اماكنها (سيعمل الكود بدون مشاكل)
ActiveWindow.Zoom

 

صف الدرجات  متغير هنا  الصف رقم 12
اذا كانت الخلية في هذا الصف ليست رقم  .. لا تتم اضافة دائرة في صفوف عمود الخلية

 

عمود رقم الجلوس العمود متغير هنا رقم 2
اذا كان هذا العمود فاضي او صفر لن تتم اضافة الدوائر

 

تم عمل زر مزدوج لإضافة وحذف الدوائر باسم (الدائرة)

Sub اضافة_حذف()
On Error Resume Next
Dim XX As Shape
Set XX = ورقة3.Shapes("الدائرة")
With XX.TextFrame.Characters
    If .Text = "اضافة الدوائر" Then
       Circles1
       .Text = "حذف الدوائر"
    Else
       RemoveCircles1
       .Text = "اضافة الدوائر"
    End If
End With
On Error GoTo 0
End Sub
Sub Circles1()
Dim C As Range
Dim MyRng As Range
Dim V As Shape
Dim X As Integer
Dim G As Integer, R As Integer
'================================================
'    عمود رقم الجلوس
G = 2
'    صف الدرجات
R = 12
' نطاق الخلايا الذي تريد اضافة الدوائر فيها
Set MyRng = Range("N13:BQ47")
'=================================================
' اذا كانت النطاقات مختلفة يمكنك الاشارة اليهم بالتالي
'Set MyRng = Range("O13:O47,Q13:Q47,S13:S47")
'=================================================
X = ActiveWindow.Zoom
Application.ScreenUpdating = False
ActiveWindow.Zoom = 100
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 1
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Value = "غ" Or C.Value = "غـ") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 1, C.Top + 1, C.Width - 2, C.Height - 2)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.25
    End If
1 Next
ActiveWindow.Zoom = X
Application.ScreenUpdating = True
End Sub
Sub RemoveCircles1()
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
      If shp.AutoShapeType = msoShapeOval Then shp.Delete
    Next shp
End Sub

دعوه طيبه لوجه الله لكل من ساهم في هذه الملف ( عبد الله باقشير )

 

اضافة و حذف دوائر_2.rar

[ابراهيم الحداد]

بارك الله فيك . سلمت يداك

[عادل زكى]

تموت الاسود فى الغابات جوعا ولحم الضأن تأكله الكلاب

[asdhamdey]

يحفظك ربنا يا استاذ عبد الله باقشير العلامه

[ياسر خليل أبو البراء]

بارك الله فيك أخي الحبيب ناصر سعيد وجعل أعمالك في ميزان حسناتك يوم القيامة وندعو لمعلمنا الكبير عبد الله باقشير بكل خير وأن يتغمده الله برحمته في هذا الشهر الفضيل ، فكم استفدنا ولا زلنا نستفيد منه

[mohamedden]

الف شكر على هذا المجهود لكن في خلايا خالية من الارقام نريد تعديل الكود على عدم اظهار الخلايا الخالية من الارقام وشكر