تكملة برنامج المدرسة القرآنية (توزيح المراجعة في كشف المتابعة)

[أبو عبد الملك السوفي]

السلام عليكم

اساتذتنا الكرام

اود برمجة كود يقوم بتوزيع المراجعة( من  Q11 الى Q34)على 24 يوم الموجودة في كشف المتابعة والتوزيع يكون كالتالي:

سيعتمد الكود  على الخليتين R4  S4 من صفحة كشف المتابعة و صفحة المنهج

اولا يجلب الكود رقم السطر الموجودة فيه السورة المكتوبة في الخليتان  S4  R4 في صفحة المنهاج    

مثلا الطالب وليد زاوي صاحب الرقم 1 مكتوب لديه الحجرات18 لو ذهبنا الى صفحة المنهج فنجدها  تقع في السطر 312

ثانيا يقوم الكود يقسمة الرقم 312على 24 فنجد13 (اذا كان بالفواصل يقربه الى الاعلى)

اي ان الطالب سيراجع في اليوم 13 سطر

فيكتب الكود في :

الخلية Q11 من السطر 1 الى السطر 13 أي (الفاتحة1 - الكوثر 3)

الخلية Q12 من السطر 14 الى السطر 26(14+12=26) أي (الماعون1 - العاديات6)

الخلية Q13 من السطر 27 الى السطر 39 (27+12=39)أي (العاديات7- التين8)

وهكذا الى الخلية Q34

ملاحظة: اذا كان المقسوم على 24 اقل من48 فيترك الكود الخلايا فارغة

 

ارجدو ان اكود قد وفقت لتوضيح المطلوب

 

Quran School V11.2.rar

[أبو عبد الملك السوفي]

للرفع رفع الله درجتكم وأعلى مكانكم

[أبو عبد الملك السوفي]

للرفع

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

 

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

أخي الحبيب أبو عبد الملك

ما زلت أحاول وإن شاء الله تنجح المحاولات ..

سر بيني وبينك دي حوالي المحاولة رقم 25 لتحقيق المطلوب ..

إن شاء الله أنا واثق إني مع انتهاء المحاولة رقم 49 هنجح في الوصول للمطلوب

عموماً ربنا ييسر الحال .. لا تقلق أنا مش ناسيك

تقبل تحياتي

[أبو عبد الملك السوفي]

السلام عليكم

والله اعجز عن شكرك استاذ ياسر

والله لا ادري ما اقول إلا ان اقف لك وقفة احترام وتقدير

بوركت وبورك علمك

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

أخي الكريم أبو عبد الملك

مشكور على كلماتك الرقيقة

إليك الكود التالي عله يفي بالغرض

Sub FollowAll()
    Dim I As Long, lRow As Long
    Dim rngFound As Range
    Dim wsRecord As Worksheet, wsMonthly As Worksheet, SH As Worksheet
    Set wsRecord = Sheets("معلومات التسجيل"): Set wsMonthly = Sheets("مجمع النتائج الشهرية"): Set SH = Sheets("كشف متابعة")

    With Application
        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
    End With

    With wsRecord
        For I = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
            If Not IsEmpty(.Cells(I, "N")) Then
                If MsgBox("الطالب " & .Cells(I, "C") & " منقطع هل تود أن تطبع له كشف?", vbYesNo + vbMsgBoxRtlReading) = vbYes Then
                    GoTo Continue
                Else: End If
            Else
Continue:
                SH.Range("C1") = .Cells(I, "C")
                SH.Range("C4") = .Cells(I, "B")
                SH.Range("C5") = .Cells(I, "A")

                Set rngFound = wsMonthly.Columns("C:C").Find(What:=.Cells(I, "C"), searchorder:=xlByRows, searchdirection:=xlPrevious)
                If Not rngFound Is Nothing Then
                    lRow = rngFound.Row
                    If wsMonthly.Cells(lRow, "R") >= 60 Then
                        SH.Range("R4") = wsMonthly.Cells(lRow, "N"): SH.Range("S4") = wsMonthly.Cells(lRow, "O")
                    ElseIf wsMonthly.Cells(lRow, "R") < 60 Then
                        SH.Range("R4") = wsMonthly.Cells(lRow, "L"): SH.Range("S4") = wsMonthly.Cells(lRow, "M")
                    Else
                        MsgBox "لا يوجد درجة للطالب " & .Cells(I, "C"), vbCritical
                    End If
                End If

                SH.Range("C2").Formula = "=IF(" & SH.Range("R4").Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & SH.Range("R4").Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$B$2:$B$6))"
                SH.Range("C3").Formula = "=IF(" & SH.Range("R4").Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & SH.Range("R4").Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$D$2:$D$6))"
                SH.Range("C2:C3").Value = SH.Range("C2:C3").Value
                
                Call CalculateLinesOfRevision
                SH.PrintPreview
            End If
        Next I
    End With

    With Application
        .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic
    End With
End Sub

Private Sub CalculateLinesOfRevision()
    Dim SH As Worksheet, wsMnhg As Worksheet
    Dim LRCur As Long, I As Long, N As Long, Counter As Long
    Dim rngA As Range, rngB As Range, rngC As Range, rngD As Range
    Dim X, Y

    Set SH = Sheets("كشف متابعة"): Set wsMnhg = Sheets("المنهج")
    
    With wsMnhg
        LRCur = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rngA = .Range("A2:A" & LRCur): Set rngB = .Range("B2:B" & LRCur)
        Set rngC = .Range("C2:C" & LRCur): Set rngD = .Range("D2:D" & LRCur)
        
        SH.Range("Q11:Q34").ClearContents
        X = ValueLookUp(rngB, SH.Cells(4, "R").Value, rngC, rngD, SH.Cells(4, "S").Value, rngA)
    
        If X <= 24 Then
            For I = 2 To X + 1
                SH.Cells(N + 11, "Q") = .Cells(I, "B") & " " & .Cells(I, "C") & " - " & .Cells(I, "B") & " " & .Cells(I, "D")
                N = N + 1
            Next I
        Else
            Y = Application.WorksheetFunction.Ceiling(X / 24, 1)
            For I = 2 To X + 1 Step Y
                SH.Cells(N + 11, "Q") = .Cells(I, "B") & " " & .Cells(I, "C") & " - " & .Cells(I + Y - 1, "B") & " " & .Cells(I + Y - 1, "D")
                N = N + 1
                Counter = Counter + Y
                If Y >= X - I Then Exit For
            Next I
            If X - Counter > 0 Then SH.Cells(N + 11, "Q") = .Cells(I + Y, "B") & " " & .Cells(I + Y, "C") & " - " & .Cells(X + 1, "B") & " " & .Cells(X + 1, "D")
        End If
    End With
End Sub

 

[أبو عبد الملك السوفي]

السلام عليكم

بوركت استاذ ابو البراء

هذا يكفي بالغرض

مماز جدا استاذ

هل نواصل استاذ ام في الامر كفاية

والله صراحة اصبحت استحيي منك استاذ ياسر

 

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

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

يمكنك بدء موضوع جديد بطلب جديد لعل أن يشارك فيه أحد الأخوة ..

وإن شاء الله يشارك الجميع

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

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

فأعتقد أنك قطعت شوطاً كبيراً جداً في البرنامج

كله بفضل الله ونعمته ومنته فالحمد لله الذي بنعمته تتم الصالحات

تقبل تحياتي

[أبو عبد الملك السوفي]

الحمد لله الذي بنعمته تتم الصالحات

أسأل الله ان يكون هذا العمل لك صدقة جارية

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

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

ارجوا ان يساعدنا الاساتذة الكرام  مأجورين ان شاء الله تعالى

تم تعديل سبتمبر 6, 2015 بواسطه أبو عبد الملك السوفي