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

**يوسف عطا** · أبريل 14, 2019

السلام عليكم أساتذتنا الأفاضل

مرفق كود لأحد الأفاضل الغاليين المتميزين بالمنتدى المحترم

الكود يعمل جيداً و المطلوب تعديل بسيط عليه

فكرة الكود وضع دائرة فى خلية الدرجة النهائية للمادة إذا كانت أقل من درجة النجاح

المطلوب إضافة شرطين فى الكود ليضع دائرة فى نفس الخلية حتى لو كانت بها درجة أعلى من درجة النجاح إذا كانت خلية أخرى فى نفس السطر بها أحد الشرطين التاليين

1. أن تكون بها حرف غ

2. أن تكون بها درجة أقل من 21

ومرفق الملف التجريبى و يحتوى على الكود المرفق

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 = 13       '    صف الدرجات
Set MyRng = Range("W14:W1013,AF14:AF1013,AO14:AO1013,BA14:BA1013,BM14:BM1013,BQ14:BQ1013,BU14:BU1013,CF14:CF1013,CO14:CO1013,DA14:DA1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
X = ActiveWindow.Zoom
Application.ScreenUpdating = False
ActiveWindow.Zoom = 100
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 1
    If C.Value = "" 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.Offset(0, -1).Value < Cells(R, C.Column - 1) Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
1 Next
Set MyRng = Range("BV14:BV1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 2
    If C.Value = "" Then GoTo 2
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Offset(0, -1).Value < Cells(R, C.Column - 1) Or C.Offset(0, -2).Value < Cells(R, C.Column - 2) Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
2 Next

Set MyRng = Range("AX14:AX1013,bj14:bj1013,CX14:CX1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 3
    If C.Value = "" Then GoTo 3
    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 = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
3 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

تجربة تعديل كود دوائر.xls

**يوسف عطا** · أبريل 14, 2019

للرفع رفع الله قدركم
الإمتحانات على الابواب و نحتاج التعديل على الكود سريعاً
جازاكم الله خير اساتذتنا

**ابراهيم الحداد** · أبريل 14, 2019

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

اجعل الكود هكذا

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 = 13       '    صف الدرجات
Set MyRng = Range("W14:W1013,AF14:AF1013,AO14:AO1013,BA14:BA1013,BM14:BM1013,BQ14:BQ1013,BU14:BU1013,CF14:CF1013,CO14:CO1013,DA14:DA1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
X = ActiveWindow.Zoom
Application.ScreenUpdating = False
ActiveWindow.Zoom = 100
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 1
    If C.Value = "" Then GoTo 1
    On Error Resume Next
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) _
    Or C.Offset(0, -1).Value < Cells(R, C.Column - 1) Or C.Offset(0, -3).Value < Cells(R, C.Column - 3) _
    Or C.Offset(0, -3).Value Or C.Offset(0, -3).Value = "" Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
1 Next
Set MyRng = Range("BV14:BV1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 2
    If C.Value = "" Then GoTo 2
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Offset(0, -1).Value < Cells(R, C.Column - 1) Or C.Offset(0, -2).Value < Cells(R, C.Column - 2) Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
2 Next

Set MyRng = Range("AX14:AX1013,bj14:bj1013,CX14:CX1013")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 3
    If C.Value = "" Then GoTo 3
    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 = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
3 Next


ActiveWindow.Zoom = X
Application.ScreenUpdating = True
MsgBox "تم إضافة   " & D & "   دائرة بنجاح", vbMsgBoxRtlReading, "الحمدلله"
End Sub

**Ali Mohamed Ali** · أبريل 14, 2019

أحسنت استاذ ابراهيم جعله الله فى ميزان حسناتك

**احمد بدره** · أبريل 14, 2019

بارك الله فيك أستاذنا الفاضل ولكن هناك ملحوظة في السطر

Or C.Offset(0, -3).Value Or C.Offset(0, -3).Value = "" Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then

سهوًا لم تكتب شرط = "غ"

فيصبح

Or C.Offset(0, -3).Value = "غ" Or C.Offset(0, -3).Value = "" Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then

حتى يعمل الكود بشكل سليم

فالكود بعد التصويب

وجزاك الله خيرًا وجعله في ميزان حسناتك

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 = 13       '    صف الدرجات
Set MyRng = Range("W14:W1013,AF14:AF1013,AO14:AO1013,BA14:BA1013,BM14:BM1013,BQ14:BQ1013,BU14:BU1013,CF14:CF1013,CO14:CO1013,DA14:DA1013") ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
X = ActiveWindow.Zoom
Application.ScreenUpdating = False
ActiveWindow.Zoom = 100
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 1
    If C.Value = "" Then GoTo 1
    On Error Resume Next
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) _
    Or C.Offset(0, -1).Value < Cells(R, C.Column - 1) Or C.Offset(0, -3).Value < Cells(R, C.Column - 3) _
     Or C.Offset(0, -3).Value = "غ" Or C.Offset(0, -3).Value = "" Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
1 Next
Set MyRng = Range("BV14:BV1013") ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 2
    If C.Value = "" Then GoTo 2
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Offset(0, -1).Value < Cells(R, C.Column - 1) Or C.Offset(0, -2).Value < Cells(R, C.Column - 2) Or C.Value = "غ" Or C.Value = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
       D = D + 1
    End If
2 Next

Set MyRng = Range("AX14:AX1013,bj14:bj1013,CX14:CX1013") ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 3
    If C.Value = "" Then GoTo 3
    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 = "غـ" Or C.Value = "صفر") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 2, C.Top + 2, C.Width - 4, C.Height - 4)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.5
        D = D + 1
    End If
3 Next

ActiveWindow.Zoom = X
Application.ScreenUpdating = True
MsgBox "تم إضافة " & D & " دائرة بنجاح", vbMsgBoxRtlReading, "الحمدلله"
End Sub

**يوسف عطا** · أبريل 14, 2019

جارى التجربة يا أساتذتنا المحترمين
و الف شكر لتعاونكم

جعله الله فى موازين حسناتكم

**يوسف عطا** · أبريل 15, 2019

الاستاذ الفاضل ابراهيم الحداد
بعد التحية
الكود الذى أرفقته سيادتكم يعطينى إرور
ولا يعمل
و مرفق الملف وبه الكود

تعديل ابراهيم.xls

**يوسف عطا** · أبريل 15, 2019

الاستاذ الفاضل أحمد بدرة
تحية طيبة
الف شكر لتعبك معانا

الكود الذى أرفقته حضرتك يقوم بوضع الدوائر و لكنه لا يحذفها

أرجو إضافة خاصية الحذف التى كانت موجودة فى الكود الأصلى

حيث كان زر الكود تظهر عليه كلمة إضافة الدوائر عندما تكون الدوائر مش موجودة
و تظهر عليه كلمة حذف الدوائر عندما تكون الدوائر موجودة

ومرفق الملف به الكود

الف شكر مرة أخرى

تعديل أحمد.rar

**احمد بدره** · أبريل 15, 2019

أستاذ يوسف عطا كل ما عملته هو أنه لاحظت كود أستاذنا الفاضل الأستاذ إبراهيم لا يعمل ووجدت السبب الذي يجعله لا يعمل

فالملف الذي أرفقته في الملف التجريب به عدد 3 ماكرو أحدهم يجمع عمل كودين بحيث إذا تم تشغيل كود الدوائر يظهر كود حذف الدوائر بالتبادل

و تم التعديل بإضافة الكود الذي يجعمل الكودين وكود الحذف وإليك الملف بعد التعديل

تعديل أحمد.rar

**يوسف عطا** · أبريل 15, 2019

الف شكر استاذنا الفاضل احمد بك

تسجيل الدخول

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

الردود الموصى بها

يوسف عطا

يوسف عطا

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

Ali Mohamed Ali

احمد بدره

يوسف عطا

يوسف عطا

يوسف عطا

احمد بدره

يوسف عطا

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information