تعديل كود لتحسين خيارات الطباعة

أبو عبد الملك السوفي · أكتوبر 14, 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")
                 SH.Range("R5") = .Cells(I, "Q")

                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

Quran School V14 الرسمي.rar

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

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

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

للرفع

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

للرفع

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

هل من متطوع لتعديل كود الاستاذ ياسر

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

ياسر خليل أبو البراء · أكتوبر 16, 2015

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

يرجى توضيح الأمر بشكل أدق ..

يرجى تحديد متى تريد إظهار الرسالة ؟؟ وعند اختيار الكل هل سيتم استكمال عمل الكود ؟

وإذا تم اختيار طالب واحد فمن هو الطالب كيف ستحدده ؟؟ هل من خلال InputBox أي صندوق إدخال أم أنه سيكون الطالب الافتراضي بورقة العمل

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

السلام عليكم

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

لقد شرعنا في الاعلمل بالبرنامج الذي صممته وهو يعمل بشكل ممتاز جدا

لكن واجهنا هذا المشكل لما نخطئ لطالب ونود طباعة كشف آخر له لا نستطيع

لانه عند الضغط على زر طباعة يطبع كشوف لكل الطلبة ولا يتوقف

لكن ايرد اخال تغيير لما اضغط طباعة يخيرني هل تريد طباعة الكل

فان ضغطت نعم يطبع الكل وان ضغطت لا يظهر لي InputBox لاكتب رقم الطالب الذي اود الطباعة له

ياسر خليل أبو البراء · أكتوبر 16, 2015

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

إليك الكود بعد التعديل عله يفي بالغرض (يرجى مراجعة النتائج جيداً ...لأنني لم اختبر الكود بشكل كافي)

Sub FollowAll()
    Dim I As Long, lRow As Long
    Dim rngFound As Range, Answer
    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
        If MsgBox("هل تريد طباعة كل كشوف الطلبة أم تريد أن تختار طالب معين؟", vbYesNo + vbMsgBoxRtlReading) = vbYes Then
            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")
                    SH.Range("R5") = .Cells(I, "Q")
                    
                    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
        Else
            Answer = Application.InputBox("أدخل رقم الطالب بناءً على ورقة معلومات التسجيل", "Input", 1)
            SH.Range("C1") = .Cells(Answer + 1, "C")
            SH.Range("C4") = .Cells(Answer + 1, "B")
            SH.Range("C5") = .Cells(Answer + 1, "A")
            SH.Range("R5") = .Cells(Answer + 1, "Q")
            
            Set rngFound = wsMonthly.Columns("C:C").Find(What:=.Cells(Answer + 1, "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(Answer + 1, "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
    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

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

السلام عليكم

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

عمل أكثر من رائع جزاك الله الجنة

ياسر خليل أبو البراء · أكتوبر 16, 2015

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

لا تنسانا كلما عملت على هذا البرنامج أن تخصني بالدعاء دائماً .. هذا هو أجري منك ..

طول ما إنت شغال على البرنامج تدعي لي ..

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

تقبل تحياتي

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

ان شاء الله استاذ ياسر سيبقى البرنامج صدقة جارية لك

وانا آسف على كثرت طلباتي

مشكور استاذ ياسر

تسجيل الدخول

تعديل كود لتحسين خيارات الطباعة

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

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

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

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

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

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

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

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

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

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

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

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

Join the conversation

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

تصفح الموقع

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

Support

Important Information