تغيرر معاينة قبل الطباعة بالطباعة في الكود

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

السلام عليكم

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

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

 

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

أخي الحبيب

جرب أن تغير السطر التالي

 SH.PrintPreview

غير كلمة PrintPreview إلى Print

تقبل تحياتي

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

لم تصلح استاذ يظهر لي خطأ

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

ما هي رسالة الخطأ التي تظهر لك؟

يمكنك النقر على كلمة Debug ثم سيظهر لك سطر باللون الأصفر .. يرجى نسخ السطر

وكتابة رسالة الخطأ

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

صور الخطأ في المرفقات

My Pictures.rar

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

أعتذر عن الخطأ إليك السطر الصحيح

SH.PrintOut

 

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

السلام عليكم

الامر تمام استاذ ياسر

لا تعتذر استاذ ياسر انا من يجب عليه الاعتذار لاني اخذت الكثير من وقت

سنتوقف في هذا الحد رغم ان البرنامج مازال لم يكتمل لكن المهم فيه اكتمل

بوركت استاذ ياسر واعذرني على الازعاج