إجمالي مرات مشاهدة الصفحة

الخميس، 26 مايو 2016

وضع دوائر حمراء حول مواد الرسوب Draw Red Circles

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

كثرت الموضوعات التي تتناول هذه القضية ، وهي كيفية وضع دوائر حمراء حول مواد الرسوب ، فأحببت أن أقدم لكم كود يسهل عليكم المسألة إن شاء الله


الكود يقوم بوضع دوائر حول مواد الرسوب ، وكل ما عليك هو تحديد ثلاثة أمور وتعديلها في الكود
أولاً تقوم بتحديد الأعمدة التي ستتعامل معها ، بفرض أن الأعمدة الملونة باللون الأصفر هي الأعمدة المطلوب رسم دوائر حمراء بها ، فمن خلال الكود ستكتب في مصفوفة الأعمدة أسماء تلك الأعمدة وهي H و K و N
ثانياً تحدد الصف الذي يحتوي على درجات النهاية الصغرى أي الدرجة التي يحصل عليها الطالب لكي يجتاز تلك المادة ، فإذا كانت درجة الطالب أقل من الدرجة الموجودة في هذا الصف يقوم الكود بوضع دائرة حمراء حول تلك الدرجة
ثالثاً تحدد صف البداية وعادةًُ يكون الصف التالي لصف درجات النهاية الصغرى ، ولكن أحببت أن يكون هناك مرونة أكثر

وأخيراً إليكم الكود الذي يؤدي المهمة ، ويوجد بالكود كود آخر يقوم بإزالة الدوائر الحمراء
Option Base 1

Sub DrawRedCircles()
    Dim myArray     As Variant
    Dim Rng         As Range
    Dim Cel         As Range
    Dim Cell        As Range
    Dim L           As Long
    Dim T           As Long
    Dim W           As Long
    Dim H           As Long
    Dim X           As Long
    Dim rRow        As Long
    Dim startRow    As Long

    'مصفوفة بأسماء الأعمدة المراد وضع دوائر حمراء بها
    myArray = Array("H", "K", "N")

    'رقم الصف الذي يحتوي على درجات النهاية الصغرى
    rRow = 3

    'صف البداية أي أول صف به درجات الطلاب
    startRow = 4

    Application.ScreenUpdating = False
        Call RemoveCircles
        
        With Sheets("Sheet1")
            For X = LBound(myArray) To UBound(myArray)
                Set Cel = .Range(myArray(X) & rRow)
                Set Rng = .Range(myArray(X) & startRow, .Range(myArray(X) & startRow).End(xlDown))
    
                For Each Cell In Rng
                    If Cell.Value < Cel Or Cell.Value = "غ" Then
                        L = Cell.Left: T = Cell.Top
                        W = Cell.Width: H = Cell.Height
    
                        With .Shapes.AddShape(msoShapeOval, L, T, W, H)
                            .Fill.Visible = msoFalse
                            .Line.ForeColor.RGB = RGB(255, 0, 0)
                            .Line.Transparency = 0
                            .Line.Weight = 1.5
                        End With
                    End If
                Next Cell
            Next X
        End With
    Application.ScreenUpdating = True
End Sub

Sub RemoveCircles()
    Dim Ws As Worksheet
    Dim Shp As Shape

    Set Ws = Sheets("Sheet1")
    For Each Shp In Ws.Shapes
        If Shp.Type = msoAutoShape Then Shp.Delete
    Next Shp
End Sub


تحميل الملف من هنا

إعداد / ياسر خليل أبو البراء

هناك 12 تعليقًا:

  1. بالنسبة للدوائر الحمراء التي توضع في نتيجة الطالب اخر العام
    اي يمكن للطالب ان يكون مجموع درجة المادة اكثر من النصف بالتالي لا يضع الكود الدائرة مع ان الطالب لم يحصل علي ثلث الدرجة ويكون راسب

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

    ردحذف
  3. انا اخدت الكود وعملت ليه كوبى وباست داخل صفحة الكود فى الاكسل ولكن مشتغلش
    هل يوجد فيديو لشرح الكود حتى يكون اسهل فى التسجيل

    ردحذف
  4. السلام عليكم ورحمة الله وبركاته
    الشكر والتقدير أستاذي / ياسر خليل
    قمت بتطبيق الكود على الشيت الأساسي، ولكن عندما قمت بإدراج موديول جديد وتطبيقه على شيت آخر في نفس المصنف بعد إجراء التعديلات لم يتم تنفيذه بنفس الذي تم من قبل أعطاني خطأ في معادلة شرط قيمة الخلية التي بها "غ"'

    ردحذف
  5. أخي الكريم أشرف
    الموضوع بسيط حاول تقوم بالإطلاع على موضوع "بداية الطريق لإنقاذ الغريق" أول موضوع بالمدونة ، لمعرفة الأساسيات في التعامل مع محرر الأكواد ..
    وإن شاء الله لو فيه أي استفسار يرجى طرحه بمنتدى أوفيسنا وإن شاء الله نفيدك

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

    ردحذف
  6. الف الف شكر لحضرتك مجهود رائع جزاك الله عليه

    ردحذف
  7. أختي الكريمة عايدة أهلاً بكي في المدونة ومشكور على مرورك العطر
    وجزيتي خيراً بمثل ما دعوتي لي

    ردحذف
  8. جزاك الله خير اخي الاستاذ ياسر .. عند تطبيق الكود يتم مسح زر الماكروا من الشيت سواء لعمل الدوائر او زر حذفها .

    ردحذف
  9. وجزيت خيراً أخي الحبيب أحمد الحاوي ، ولم بمثل إن شاء الله
    يتم مسح الأشكال في ورقة العمل التي يطبق فيها الكود ولكن يمكن عمل استثناء في كود الإزالة لهذا الشكل المرتبط بتنفيذ الكود أو يمكن رسم زر أمر بدلاً من الأشكال وربطها بالكود

    ردحذف
  10. السلام عليكم
    يمكن حذف الدوائر فقط بالامر
    Worksheets("Sheet1").Ovals.Delete

    ردحذف
  11. وعليكم السلام أخي الحبيب محتار
    شرفني مرورك وإضافتك الجميلة
    تقبل وافر تقديري واحترامي

    ردحذف
  12. .انضم إلى eToro وقُد ثورة التكنولوجيا المالية

    اكتشف eToro شبكة التداول الاجتماعي الرائدة في العالم حيث يحقق ملايين المستخدمين أرباحًا عن طريق نسخ تصرفات التداول التي يقوم بها أفضل المتداولين.

    ردحذف