تجميع 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

 

[بلانك]

بدأ يضبط ..............ولكن انظر للصورة المفروض لا يترك اي يوم بدون دائرة قبل ازدواج الدوائر

[Foksh]

لم افهم بالضبط !!!!

يعني النتيجة المطلوبة ، أنه حتى يوم الاربعاء الحصة 2-3 تكون عليها دائرة ؟؟؟

بدلاً من الحصة الخامسة ليوم الإثنين !!!

[بلانك]

أخي فوكش ..... ان جميع الايام لابد من توزيع الدوائر على الحصص اولا من اخر حصة فئ ذلك اليوم   ... ثم لو زادت الحصص عن عدد الايام يبدا الازدواج في الدوائر للحصص التى قبلها  .... بمعنى في اخر صورة عدد الحصص 6 وعدد الايام 3 اذا كل يوم دائرتان من الاخر لذلك اليوم

[Foksh]

علني اكون قد فهمت المنطق جيداً ..

تفضل التعديل :-

Sub DrawCirclesByFoksh(ByVal x As Integer, ByVal startRow As Integer, ByVal endRow As Integer)
    Dim Shp As Shape
    Dim r As Long, i As Long, n As Long
    Dim c As Range
    Dim usedRows As Collection
    Dim dayCount As Long, perDay As Long, extra As Long
    Dim rr As Variant, lastCol As Long
    Dim hasLesson As Boolean
    
    If x <= 0 Then Exit Sub
    
    Set usedRows = New Collection
    For r = startRow To endRow
        hasLesson = False
        For i = 3 To 10
            If Cells(r, i).Value <> "" Then
                hasLesson = True
                Exit For
            End If
        Next i
        If hasLesson Then usedRows.Add r
    Next r
    
    dayCount = usedRows.Count
    If dayCount = 0 Then Exit Sub
    
    perDay = x \ dayCount
    extra = x Mod dayCount
    
    n = 0
    
    For Each rr In usedRows
        Dim circlesThisDay As Long
        circlesThisDay = perDay
        If extra > 0 Then
            circlesThisDay = circlesThisDay + 1
            extra = extra - 1
        End If
        
        lastCol = 0
        For i = 10 To 3 Step -1
            If Cells(rr, i).Value <> "" Then
                lastCol = i
                Exit For
            End If
        Next i
        
        For i = lastCol To 3 Step -1
            If Cells(rr, i).Value <> "" And circlesThisDay > 0 Then
                Set c = Cells(rr, i)
                Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, _
                    c.Left, c.Top, c.Width, c.Height)
                Shp.Fill.Visible = msoFalse
                Shp.Line.Weight = 1
                Shp.Line.ForeColor.SchemeColor = 10
                circlesThisDay = circlesThisDay - 1
                n = n + 1
                If n >= x Then Exit Sub
            End If
        Next i
    Next rr
End Sub

 

[بلانك]

تمام بارك الله فيك هو ده المطلوب زادك الله علما على علم

[Foksh]

أنصحك أخي @بلانك ، بتجربة إحتمالات كثيرة على النتيجة والتحقق منها 100% 😉

[بلانك]

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