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

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

السلام علكيم

كيف حالكم احبابنا الكرام هذا الموضوع تابع للمواضيع سابقة بنفس العنوان واود في هذا الموضوع الجديد اتمام الكود الخاص بصفحة كشف المتابعة ولم يبقى الا استقدام المعلومات الخاصة بعمود الاسبوعي(G34 - G11)

والاستقدام يكود كالتالي:

- اولا/ الكود يعتمد على الخلية S4 R4

-ثانيا/مثلا اذا كان لدينا طالب يبيدأ حفظه من الفتح1 (نعلم ان الفتح 1 تقع في السطر 313 في صفحة المنهج )

فيبدأالكود بالسطر  314 و يضيف لها 5 اسطر (314+5=319  أي سورة الفتح 17)

فيكتب في الخلية G11 يكتب(314 ـــ 319) اي يكتب الفتح5 - الفتح 17

ثم في الخلية G12 يكتب(314+1  ـــ 319+1) اي يكتب الفتح7 - الفتح 20

ثم في الخلية G13 يكتب(314+2  ـــ 319+2) اي يكتب الفتح11 - الفتح 24

ثم في الخلية G13 يكتب(314+3  ـــ 319+3) اي يكتب الفتح12- الفتح 25

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

وبشكل آخر أن الطالب سيحضر 6 اسطر التي سيحفظها في الـ 6 ايام القادمة

ارجوا ان تكون الفكرة قد وصلت

Quran School V13.rar

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

للرفع رفع الله كعبكم وبيض وجوهكم

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

للرفع

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

للرفع

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

للرفع

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

للرفع رفع الله ذكركم

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

السلام عليكم

للرفع بورك فيكم

مضى على الموضوع أكثر من 10 أيام وأنا في حاجة ماسة لهذا البرنامج

جزاكم الله كل خير ونفع بكم

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

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

جرب الكود التالي بعد التعديل

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, II As Long, N As Long, Counter As Long, P As Long
    Dim rngA As Range, rngB As Range, rngC As Range, rngD As Range
    Dim X, Y, Z

    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

        SH.Range("O11:O34").ClearContents
        Z = X - 24
        If Z > 0 Then SH.Range("O11:O34") = .Cells(Z, "B") & " " & .Cells(Z, "D") & " - " & SH.Range("R4") & " " & SH.Range("S4")
        
        SH.Range("M11:M34,I11:I34,G11:G34").ClearContents
        P = 1
        For II = 11 To 34
            SH.Range("M" & II) = .Cells(X + P, "B") & " " & .Cells(X + P, "C") & " - " & .Cells(X + P, "D")
            SH.Range("I" & II) = .Cells(X + P + 1, "B") & " " & .Cells(X + P + 1, "C") & " - " & .Cells(X + P + 1, "D")
            SH.Range("G" & II) = .Cells(X + P + 1, "B") & " " & .Cells(X + P + 1, "C") & " - " & .Cells(X + P + 6, "B") & .Cells(X + P + 6, "D")
            P = P + 1
        Next II
        
        SH.Range("M11:M34").Copy SH.Range("K11")
    End With
End Sub

 

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

السلام عليكم

بوركت استاذ ياسر

منذ مدة وانا انتظر ردك

شكرا جزيلا الكود يعمل بشكل جيد

هل يمكن ان تعوض المعاينة بالطابعة الآن