اذهب الي المحتوي
أوفيسنا

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

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

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

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

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

قام بنشر
قام بنشر (معدل)

السلام عليكم

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

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

أود في هذا الموضوع معالجة مراجعة القريب(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

تم تعديل بواسطه أبو عبد الملك السوفي
رابط هذا التعليق
شارك
ياسر خليل أبو البراء

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

قام بنشر
قام بنشر

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

إليك الكود بالكامل ..تم إضافة ثلاثة أسطر لتؤدي الغرض في نهاية الكود قبل جملة 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

 

  • Like 3
رابط هذا التعليق
شارك
أبو عبد الملك السوفي

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

قام بنشر
  • الكاتب
قام بنشر

السلام عليكم

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

الكود جيد جدا

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

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

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

* المحفوظ الجديد(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

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

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

 

رابط هذا التعليق
شارك
ياسر خليل أبو البراء

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

قام بنشر
قام بنشر

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

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

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

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

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

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

 

  • Like 2
رابط هذا التعليق
شارك
أبو عبد الملك السوفي

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

قام بنشر
  • الكاتب
قام بنشر (معدل)

السلام عليكم

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

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

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

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

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

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

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

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

تم تعديل بواسطه أبو عبد الملك السوفي
  • Like 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept