تعديل فى الدوائر

[waledms]

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

 أرجو ضبط  الكود بحيث ينظر إلى الدرجة إذا كانت أكبر من النصف ( النهاية الصفرى ) ولكن فى خانة المستوى ( دون المستوى ) يتم وضع المربع على الدرجة ...... وإذا كانت الدرجة اصغر من النهاية الصغرى يتم وضع دائرة عليها ..... كما بالصورة الموجود عليها الشيت الذى قمت بتعديله يدوياً 

 

‏‏2018شيت مدرستى - الصف الرابع- -.rar

[waledms]

حاولت التعديل على الكود ولكن تظهر المربعات فى غير موضعها

[أ / محمد صالح]

تفضل أخي الكريم

تم اختصار الكود وتسهيله ليقوم بالمهمة المطلوبة

Sub Circles1()
Dim C As Range, MyRng As Range, V As Shape
Dim x As Integer, R As Integer
R = 5       '    صف النهاية الصغرى
Set MyRng = Range("c6:x130")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
Application.ScreenUpdating = False
Call DeletingShp
On Error Resume Next
For Each C In MyRng
If C.Value = "" Then GoTo 2
    If C.Value < Cells(R, C.Column).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.9
    ElseIf C.Offset(0, 1).Value = "دون المستوى" Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeRectangle, C.Left + 1, C.Top + 1, C.Width - 2, C.Height - 2)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 4
        V.Line.Weight = 1.9
    End If
2 Next
Application.ScreenUpdating = True
MsgBox "تم إضافة الدوائر بنجاح", vbMsgBoxRtlReading, "الحمدلله"
End Sub

وفقنا الله وإياكم لكل خير

[waledms]

جزاك الله خيراً ..... 

لكن لماذا يظهر ظل للدوائر والمربعات

‏‏2018شيت مدرستى - الصف الرابع- -.rar

[أ / محمد صالح]

عندي هذا الكود لا يضيف ظلا للدوائر

لكن يبدو أنه يوجد شيء غريب في إعدادات الشيت الخاص بك

والحل بسيط جدا أضف هذا السطر لوقف الظل

        V.Shadow.Visible = msoFalse

بعد السطر

        V.Line.Weight = 1.9

ليصبح الكود كاملا بهذه الصورة

Sub Circles1()
Dim C As Range, MyRng As Range, V As Shape
Dim x As Integer, R As Integer
R = 5       '    صف النهاية الصغرى
Set MyRng = Range("c6:x130")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
Application.ScreenUpdating = False
Call DeletingShp
On Error Resume Next
For Each C In MyRng
If C.Value = "" Then GoTo 2
    If C.Value < Cells(R, C.Column).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.9
        V.Shadow.Visible = msoFalse
    ElseIf C.Offset(0, 1).Value = "دون المستوى" Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeRectangle, C.Left + 1, C.Top + 1, C.Width - 2, C.Height - 2)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 4
        V.Line.Weight = 1.9
        V.Shadow.Visible = msoFalse
    End If
2 Next
Application.ScreenUpdating = True
MsgBox "تم إضافة الدوائر بنجاح", vbMsgBoxRtlReading, "الحمدلله"
End Sub

بالتوفيق

[waledms]

شكراً ... جزاك الله خيراً...... تم الحل