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

[عبد العزيز البسكري]

أين الخلل سادتي و أساتذتي الكرام في ملفي هذا ..أردت وضع الدوائر الحمراء على كشف النقاط .. في النطاق المبين في الصور المرفقة مع الملف .. واجهتني أساتذتي الأعزاء مشكلتين .. الأولى وهي عند الضغط على زر إضافة الدوائر الحمراء تضاف إلى بعض الخلايا الأكبر من القيمة المحددة في الكود وهي ( 5 ) بمعنى أنا أريد الدرجات التي بها أقل من خمسة ..الدوائر الحمراء أريدها على خلايا الدرجات من 0 إلى 4.99 في النطاق K27;K38  مع تحاشي وضعها على الخلايا الفارغة ..المشكلة الثانية و هي كما تلاحظون الدوائر الحمراء وضعت على الخلية التي معدلها عشرة 10   ..وهناك في الشيت خلايا بها 10 ولم تظهر الدوائر الحمراء بها..يعني لخبطة .. أساتذتي الكرام ساعدوني جزاكم الله خيرا و زادها بميزان حسناتكم على تصحيح الخلل :

http://up.top4top.net/downloadf-top4top_bc9fb320b91-rar.html

 

تم تعديل مارس 15, 2015 بواسطه feteh07

[عبد العزيز البسكري]

السلام عليكم .. هل من مساعدة سادتي و أساتذتي الكرام ؟؟

[عبد العزيز البسكري]

يا أساتذة يا أفاضل أعطوني السّمكة هذه المرة و لا تعلموني الصّيد .. لأني بحاجة ماسّة للموضوع

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

جرب الكود بهذه الإضافة البسيطة

Sub AddRedCircle()
    Dim c As Range
    Dim ws As Worksheet
    Dim Shp As Shape
    
    Set ws = ActiveSheet
    
    For Each c In Range("f27:k38")
        If c.Value < 5 And Not IsEmpty(c.Value) Then
            c.Select
            Set Shp = ws.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height)
            With Shp
                .Fill.Visible = msoFalse
                .Line.ForeColor.RGB = RGB(255, 0, 0)
                .Line.Weight = 2
            End With
        End If
    Next c
End Sub
Sub DeleteRedCircles()
    Dim Shp As Shape
    For Each Shp In ActiveSheet.Shapes
        If Not (Shp.Type = msoOLEControlObject Or Shp.Type = msoFormControl) Then Shp.Delete
    Next Shp
End Sub

[عبد العزيز البسكري]

 

جرب الكود بهذه الإضافة البسيطة

Sub AddRedCircle()
    Dim c As Range
    Dim ws As Worksheet
    Dim Shp As Shape
    
    Set ws = ActiveSheet
    
    For Each c In Range("f27:k38")
        If c.Value < 5 And Not IsEmpty(c.Value) Then
            c.Select
            Set Shp = ws.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height)
            With Shp
                .Fill.Visible = msoFalse
                .Line.ForeColor.RGB = RGB(255, 0, 0)
                .Line.Weight = 2
            End With
        End If
    Next c
End Sub
Sub DeleteRedCircles()
    Dim Shp As Shape
    For Each Shp In ActiveSheet.Shapes
        If Not (Shp.Type = msoOLEControlObject Or Shp.Type = msoFormControl) Then Shp.Delete
    Next Shp
End Sub

أستاذي الغالي ياسر .. بارك الله فيك و جزاك الله خيرًا على المساعدة .. قمت بوضع الكود في الملف و النتيجة أن الدوائر الحمراء وجدتها تظهر في غير مكانها ..أنا أريد الدوائر الحمراء تظهر في النطاق المحدد باللون الأخضر فقط .. طبعا في الخلايا التي بها معدلات فقط في هذا النطاق

http://up.top4top.net/downloadf-top4top_694466090a1-rar.html

تم تعديل مارس 15, 2015 بواسطه feteh07

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

جربت الملف وتظهر الدوائر بشكل منضبط لدي .. وتظهر على القيم التي أقل من 5 فقط

[عبد العزيز البسكري]

جربت الملف وتظهر الدوائر بشكل منضبط لدي .. وتظهر على القيم التي أقل من 5 فقط

بارك الله سيدي الفاضل و جزاك الله خيرًا..وكيف يمكن التخلص من الدوائر الحمراء في الخلايا الفارغة

تم تعديل مارس 15, 2015 بواسطه feteh07

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

أخي الفاضل تم ذلك .. لتجربة الكود قم بحذف الدوائر أولا ثم بتجربة الكود ..

Not IsEmpty(c.Value)

تقريبا هذه هي الإضافة التي أضفتها وضبطت الكود

تقبل تحياتي

[عبد العزيز البسكري]

أخي الفاضل تم ذلك .. لتجربة الكود قم بحذف الدوائر أولا ثم بتجربة الكود ..

Not IsEmpty(c.Value)

تقريبا هذه هي الإضافة التي أضفتها وضبطت الكود

تقبل تحياتي

بارك الله فيك و جزاك الله خيرًا أستاذي الفاضل ياسر ; زادها في ميزان حسناتك.. ..الكود يعمل تمام التمام و الدوائر الحمراء تظهر في النطاق المطلوب و الخلايا المطلوبة ..

تم تعديل مارس 16, 2015 بواسطه feteh07

[حماده سعد الله]

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

1.rar

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

أخي الكريم

أهلاً بك في المنتدى ونورت بين إخوانك ..(يا ابن ابو حماده)

يمكنك طرح موضوع جديد لطلبك حتى تجد استجابة من الأخوة الأعضاء