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

[قنديل الصياد]

مرفق كود للاستاذ القدير عبد الله باقشير (كود الدوائر الحمراء) والكود يعمل بكفاءة بشرط ان تكون صفحة درجات الطالب غير محمية بكلمة مرور

برجاء تعديل الكود لكى يعمل والصفحات تحت الحماية

Sub اضافة_حذف()
On Error Resume Next
Dim XX As Shape
Set XX = ActiveSheet.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, V As Shape
Dim X As Integer, G As Integer, R As Integer, D As Integer
'================================================
G = 2       '    عمود رقم الجلوس
R = 11       '    صف الدرجات
Set MyRng = Range("j12:j56,n12:n56,aa12:aa56,ar12:ar56")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
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
        D = D + 1
    End If
1 Next
ActiveWindow.Zoom = X
Application.ScreenUpdating = True
MsgBox "تم إضافة   " & D & "   دائرة بنجاح", vbMsgBoxRtlReading, "الحمدلله"
End Sub
Sub RemoveCircles1()
    Dim shp As Shape, D As Integer
    For Each shp In ActiveSheet.Shapes
      If shp.AutoShapeType = msoShapeOval Then shp.Delete: D = D + 1
    Next shp
MsgBox "تم حذف   " & D & "   دائرة بنجاح", vbMsgBoxRtlReading, "الحمدلله"

End Sub

تم تعديل يناير 2, 2015 بواسطه قنديل الصياد

[ابوصلاح]

تضع في بداية الكود

Sheets("اسم الشيت").Select
    ActiveSheet.Unprotect

وفي نهاية الكود

Sheets("اسم الشيت").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

[قنديل الصياد]

شكرا جزيلا ابوصلاح

تم عمل المطلوب بنجاح

[ابوصلاح]

استاذ قنديل الصياد شكرا علي الكود  كود رائع

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

أخي وأستاذي قنديل

هلا أرفقت ملف للاستفادة منه؟

[عبدالباري البنا]

اخى الحبيب ياسر 

هذا الملف يعمل تحت الحماية بدون مشاكل

جرب المرفق

الدوائر.rar

[قنديل الصياد]

استاذنا القدير الاستاذ ياسر خليل

اليك ملف ومنفذ عليه الكود وكلمة سر الملف (1900)

 

 

درجات نصف العام.rar

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

أخي وأستاذي الحبيب قنديل الصياد

بارك الله فيك وجزاك الله خير الجزاء

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

تقبلوا تحياتي :fff:

تم تعديل يناير 3, 2015 بواسطه YasserKhalil

[مختار حسين محمود]

أستاذى قنديل الصياد

                             

                      بارك الله فيكم

الملفات  دى مهمة اليومين دول  عشان امتحانات نصف العام

 

 

الملف الثانى يعمل بكفاءة

 

الملف الاول  ( الدوائر ) يعطينى خطأ  فى الفيجوال بيسك 1004

تم تعديل يناير 3, 2015 بواسطه مختار حسين محمود

[قنديل الصياد]

الاستاذ العزيز / مختار حسين

ارفق الملف الذى وجد به الخطا وباذن الله نحاول اصلاحه

تحياتي

[alsamalapi]

  سكرا لكم                                            

اريد برنامج الاجر الاضافي للموظفين