مطلوب تعديل في كود لتوزيع درجة المتوسط

[سيد الأكرت]

بسم الله الرحمن الرحيم

كود الملف المرفق من وضع الأستاذ الكبير الشهابي جزاه الله خير الجزاء والملف عبارة عن كود لتوزيع درجة المتوسط على الثلاثة شهور المطلوبة بحيث اذا قمنا بكتابة رقم مثل 35 في الخلية p9   ووضعنا درجة الامتحان في الخلية o9  وضغطنا توزيع المتوسط فان الكود يقوم بتوزيع درجات الكود بشكل معين على الثلاثة شهور وقد أتم الأستاذ الشهابي ما كان مطلوبا في الملف على أكمل وجه والمطلوب الآن هو تعديل هذا الكود ليتلائم مع تعليمات جديدة من الوزارة تتعلق بدرجة الحضور والسلوك حيث نصت التعليمات على أن التلاميذ يأخذ الدرجة فيها كاملة حتى ولو غاب أياما قليلة فأتمنى تثبيت درجة الحضور والسلوك والتي يمثلها الأعمدة d10   و h10  و l10من 10 درجات كاملة مهما كانت درجة المتوسط الموضوعة   

توزيع المتوسط.rar

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

السلام عليكم أخي الكريم سيد

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

Sub FillRandom()
    Dim lngSum As Long
    Dim i As Long
    Dim arrValues(1 To 13) As Double
    
    For i = 9 To Cells(Rows.Count, "B").End(xlUp).Row
        If Cells(i, "P").Value <> "" Then
            lngSum = Range("P" & i).Value
            Do
                arrValues(1) = Application.RandBetween(1, 10)
                arrValues(2) = 10
                arrValues(3) = Application.RandBetween(1, 20)
                arrValues(4) = Application.Sum(arrValues(1), arrValues(2), arrValues(3))
                
                arrValues(5) = Application.RandBetween(1, 10)
                arrValues(6) = 10
                arrValues(7) = Application.RandBetween(1, 20)
                arrValues(8) = Application.Sum(arrValues(5), arrValues(6), arrValues(7))
                
                arrValues(9) = Application.RandBetween(1, 10)
                arrValues(10) = 10
                arrValues(11) = Application.RandBetween(1, 20)
                arrValues(12) = Application.Sum(arrValues(9), arrValues(10), arrValues(11))
            Loop Until Application.Average(arrValues(4), arrValues(8), arrValues(12)) = lngSum
            arrValues(13) = Application.Sum(arrValues(4), arrValues(8), arrValues(12))
            
            Range("C" & i).Resize(1, 13).Value = arrValues
            Range("R" & i).Value = Application.Sum(Range("P" & i).Value, Range("Q" & i).Value)
        End If
    Next i
End Sub

 

[سيد الأكرت]

6 hours ago, ياسر خليل أبو البراء said:

السلام عليكم أخي الكريم سيد

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

Sub FillRandom()
    Dim lngSum As Long
    Dim i As Long
    Dim arrValues(1 To 13) As Double
    
    For i = 9 To Cells(Rows.Count, "B").End(xlUp).Row
        If Cells(i, "P").Value <> "" Then
            lngSum = Range("P" & i).Value
            Do
                arrValues(1) = Application.RandBetween(1, 10)
                arrValues(2) = 10
                arrValues(3) = Application.RandBetween(1, 20)
                arrValues(4) = Application.Sum(arrValues(1), arrValues(2), arrValues(3))
                
                arrValues(5) = Application.RandBetween(1, 10)
                arrValues(6) = 10
                arrValues(7) = Application.RandBetween(1, 20)
                arrValues(8) = Application.Sum(arrValues(5), arrValues(6), arrValues(7))
                
                arrValues(9) = Application.RandBetween(1, 10)
                arrValues(10) = 10
                arrValues(11) = Application.RandBetween(1, 20)
                arrValues(12) = Application.Sum(arrValues(9), arrValues(10), arrValues(11))
            Loop Until Application.Average(arrValues(4), arrValues(8), arrValues(12)) = lngSum
            arrValues(13) = Application.Sum(arrValues(4), arrValues(8), arrValues(12))
            
            Range("C" & i).Resize(1, 13).Value = arrValues
            Range("R" & i).Value = Application.Sum(Range("P" & i).Value, Range("Q" & i).Value)
        End If
    Next i
End Sub

 

أستاذنا الفاضل لا أعرف لماذا لم يعمل الكود فقد استبدلت الكود الموجود بالكود الذي كتبته حضرتك ولم يعمل

[سيد الأكرت]

up

[سيد الأكرت]

up

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

في الحقيقة حاولت في الموضوع ولم أتوصل لشيء . لربما يساعدك أحد الأخوة الكرام بالمنتدى