تجميع 3اكواد في كود واحد

[بلانك]

تجميع 3اكواد وجعلة في كود واحد

تجميع اكواد في كود واحد.xlsm

[بلانك]

up

[Foksh]

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

على حسب ما فهمت أن المقصود هو أكواد رسم الدوائر كما في ملفك المرفق ، صحيح ؟؟

طيب بدايةً .. وللتوضيح :-

إذا كانت الأعمدة تتغير ( ليس دائماً العمود 10 ) ، هنا أخي بلانك يمكنك إضافة معامل رابع للدالة DrawCircles لتحديد آخر عمود ، أو استخدام نطاق أكثر حيوية . لكن بناءً على الأكواد الحالية من ملفك المرفق ، أعتقد أن i = 10 و i >= 2 متغيران ثابتان لجميع الحالات . صحيح ؟؟

 

إذا كان ما فهمته صحيح .. فاستعمل ما يلي :-

الدالة الرئيسية :-

Sub DrawCirclesByFoksh(ByVal x As Integer, ByVal startRow As Integer, ByVal endRow As Integer)
    Dim Shp As Shape
    Dim i As Long, s As Long, n As Long
    Dim c As Range
    
    If x <= 0 Then Exit Sub
    
    i = 10
    n = 0
    
    Do While i >= 2
        For Each c In Range(Cells(startRow, i), Cells(endRow, i))
            If c.Value <> "" Then
                Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, _
                    c.Left, c.Top, c.Width, c.Height)
                n = n + 1
                Shp.Fill.Visible = msoFalse
                Shp.Line.Weight = 1
                Shp.Line.ForeColor.SchemeColor = 10
                
                If n >= x Then Exit Sub
            End If
        Next c
        i = i - 1
    Loop
End Sub

 

ثم تستدعيها من خلال الزر وبتمرير المجموعات التي تريدها ولك الحرية في ذلك ، بهذا النمط :-

Sub AddCirclesMain()
    Call DrawCirclesByFoksh(Range("n9").Value, 10, 14)
    Call DrawCirclesByFoksh(Range("n17").Value, 18, 22)
    Call DrawCirclesByFoksh(Range("n25").Value, 26, 30)
End Sub

طبعاً ستستدعي الدالة AddCirclesMain في زر رسم الدوائر .

[بلانك]

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

[Foksh]

تمام .. استبدل الدالة الرئيسية بالتالية ، وجربها على ملفك بعد إزالة الدوائر السابقة طبعاً :-

Sub DrawCirclesByFoksh(ByVal x As Integer, ByVal startRow As Integer, ByVal endRow As Integer)
    Dim Shp As Shape
    Dim i As Long, r As Long, n As Long
    Dim c As Range
    
    If x <= 0 Then Exit Sub
    
    i = 10
    n = 0
    
    Do While i >= 2
        For r = endRow To startRow Step -1
            Set c = Cells(r, i)
            If c.Value <> "" Then
                Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, _
                    c.Left, c.Top, c.Width, c.Height)
                n = n + 1
                Shp.Fill.Visible = msoFalse
                Shp.Line.Weight = 1
                Shp.Line.ForeColor.SchemeColor = 10
                
                If n >= x Then Exit Sub
            End If
        Next r
        i = i - 1
    Loop
End Sub