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

أبو عبد الملك السوفي · سبتمبر 7, 2015

السلام عليكم

كيف حال اساتذتنا الكرام

بعدما تم معالجة توزيع مراجعة البعيد في موضوع سابق

أود في هذا الموضوع معالجة مراجعة القريب(O34 O11):

بالاعتماد على الخلية S4 R4

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

ثم يحسب 25 سطرا قبلها

مثلا:

المكتوب في الخلية S4 R4 (الفتح 1)

لو ذهبنا الى صفحة المنهج نجد أن الفتح 1 رقمها 313

فنقوم بالاعملية التالية313-25= 288 (25 تعني 25 سطرا أي ان الكود يرجع للخلف بـ 25 سطرا)(اذا كانت العملية بالناقص يتم تجاهل الامر ويترك الخانات فارغة)

ثم لو ذهبنا الى صفحة المنهج نجد أن السطر 288 هو الذاريات 14

وعليه يكتب الكود في كل الخليات من O34الى O11 ( الذاريات14 - الفتح1).

Quran School V12.rar

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

أبو عبد الملك السوفي · سبتمبر 7, 2015

للرفع

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

ياسر خليل أبو البراء · سبتمبر 8, 2015

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

إليك الكود بالكامل ..تم إضافة ثلاثة أسطر لتؤدي الغرض في نهاية الكود قبل جملة End With

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, 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")
    End With
End Sub

أبو عبد الملك السوفي · سبتمبر 8, 2015

السلام عليكم

ممتاز أستاذ ياسر

الكود جيد جدا

استأذنك استاذ ياسر

في اكمال ما تبقى من الكشف

ما تبقى سهل وليس فيه تعقيد

* المحفوظ الجديد(m11 m34):

بالاعتماد على الخلية r4 s4:

مثلا اذاكان في الخلية r4 s4 مكتوب الفتح 1

اذا ذهبنا الى صفحة المنهج نجد أن رقم السطر 313:

وعليه يكتب الكود في الخلية m11: السطر 313 ( الفتح 1 - 4).

و يكتب في الخلية m12: السطر 314 ( الفتح 5 - 6).

و يكتب في الخلية m13: السطر 315 ( الفتح 7 - 10).

و يكتب في الخلية m13: السطر 316 ( الفتح 11 - 11).

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

* نفس الشيئ يكرر في القبلي(من k11 الىk34 )

* أما في الليلي(i34 i11)

نعلم ان الفتح 1 رقمها 313

وعليه فيكتب الكود في الخلية i11 السطر 314 (الفتح 5 - 6)

و يكتب في الخلية i12 السطر 315 ( الفتح 7 - 10).

وهكذا يواصل الى الخلية i34 كما فعل في المجال (m11 m34) والمجالk11 k34

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

تقبل تحياتي واحترامي استاذ ابو البراء

أبو عبد الملك السوفي · سبتمبر 9, 2015

للرفع رفع الله درجتكم

أبو عبد الملك السوفي · سبتمبر 10, 2015

للرفع

أبو عبد الملك السوفي · سبتمبر 11, 2015

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

أبو عبد الملك السوفي · سبتمبر 12, 2015

للرفع رفعكم الله عن من عاداكم وثبت الى الجنة خطاكم وحفظكم ورعاكم

أبو عبد الملك السوفي · سبتمبر 13, 2015

للرفع

بورك فيكم

ياسر خليل أبو البراء · سبتمبر 13, 2015

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

يبدو أنك نسيت المبدأ .. بدلاً من أن تقوم بالرفع للموضوع أكثر من مرة كان يمكنك طرح موضوع جديد بطلبك الجديد في غيابي وأعتقد ساعتها يمكن أن تجد استجابة

أعتقد - وهذا مجرد رأي شخصي - أن الموضوعات الجديدة تستقطب الأعضاء أكثر من الموضوعات التي بها رد مسبق لأن العضو الذي يريد المساعدة عندما يجد رد مسبق يظن أن الموضوع قد انتهى أو أنه لكي يقدم المساعدة فعليه أن يتابع الموضوع من البداية وفي هذه الحالة وقته قد لا يسمح فيعزف عن الموضوع ، أو يترك المجال لمن قام بالرد أولاً أن يقوم بالرد مرة أخرى بدون تدخل منه

عموماً معلش صدعتك

إليك الكود التالي عله يكون المطلوب

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").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")
            P = P + 1
        Next II
        
        SH.Range("M11:M34").Copy SH.Range("K11")
    End With
End Sub

أبو عبد الملك السوفي · سبتمبر 13, 2015

السلام عليكم

عسى ان تكون بخير استاذ ياسر

معك كل الحق استاذ ياسر

انا شخصيا اتابع المواضيع الجديدة واحاول المساعدة فيما اعرف

لكن لا اعرف لما لم يشارك اي من الااساتذة الكرام في الموضوع منذ بدأناه .....

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

أصبحت ارى نفسي ثقيلا عليك استاذ ابو البراء

ممتاز اساذ ياسر

بقي في هاته الصفحة عنصر واحد وهو الاسبوعي سافتح له موضوع جديد

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

تسجيل الدخول

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

الردود الموصى بها

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

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

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

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

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

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

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

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

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

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

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

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information