طباعة اكثر من صفحة

[siso3]

السلام عليكم

المطلوب كود طباعة  كود اطبع بيه الأربع صفحات او اكثر مع بعض مرة واحدة ولكن طباعة النطاق اللى انا احدده 

والنطاق ده هيكون مختلف في كل صفحة

انا مش عايز اطبع اوراق العمل كلها ولا الصفحة كاملة مناطق مختلفة من اكثر من صفطباعة اكثر من صفحة.xlsbحة بكود واحد فقط

 

واخيرا اتقدم بالشكر لحضراتكم لما تقدمونه لا عضاء المنتدى من معلومات قيمة وحلول سريعه

ولما تبذلونه من جهد ملحوظ جعله الله فى ميزان حسانات من نفع وانتفع بعلمه الناس

 

طباعة اكثر من صفحة.xlsb

تم تعديل منذ 4 ساعات بواسطه siso3

[hegazee]

وعليكم السلام ورحمة الله و بركاته

Sub PrintOrExportPDF_CustomRanges()
    Dim ws As Worksheet
    Dim rngAddress As String
    Dim sheetNames As Variant
    Dim printableSheetNames() As String
    Dim i As Integer, count As Integer
    Dim printChoice As VbMsgBoxResult
    Dim savePath As String
    Dim fileName As String

    ' أسماء الأوراق (عدّل حسب أوراقك)
    sheetNames = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")
    count = 0

    ' سؤال المستخدم: طباعة أم PDF؟
    printChoice = MsgBox("هل ترغب في طباعة الأوراق؟" & vbCrLf & "اضغط 'نعم' للطباعة، 'لا' لحفظ كـ PDF.", vbYesNoCancel + vbQuestion, "اختيار نوع الإخراج")

    If printChoice = vbCancel Then
        MsgBox "تم إلغاء العملية.", vbExclamation
        Exit Sub
    End If

    Application.ScreenUpdating = False

    ' تحديد النطاقات
    For i = LBound(sheetNames) To UBound(sheetNames)
        Set ws = ThisWorkbook.Sheets(sheetNames(i))
        rngAddress = InputBox("أدخل النطاق المطلوب طباعته من الورقة: " & sheetNames(i), "تحديد نطاق الطباعة")

        If rngAddress <> "" Then
            On Error Resume Next
            ws.PageSetup.PrintArea = rngAddress
            If Err.Number = 0 Then
                count = count + 1
                ReDim Preserve printableSheetNames(1 To count)
                printableSheetNames(count) = ws.Name
            End If
            On Error GoTo 0
        Else
            MsgBox "تم تخطي الورقة: " & sheetNames(i), vbInformation
        End If
    Next i

    ' تنفيذ العملية حسب الاختيار
    If count > 0 Then
        If printChoice = vbYes Then
            ' ? طباعة مباشرة
            Sheets(printableSheetNames).PrintOut
            MsgBox "تمت طباعة الأوراق المحددة بنجاح.", vbInformation

        ElseIf printChoice = vbNo Then
            ' ? تصدير كـ PDF (بمصنف مؤقت)
            With Application.FileDialog(msoFileDialogFolderPicker)
                .Title = "اختر المجلد لحفظ ملف PDF"
                If .Show <> -1 Then
                    MsgBox "لم يتم اختيار مجلد.", vbExclamation
                    Exit Sub
                End If
                savePath = .SelectedItems(1)
            End With

            fileName = InputBox("أدخل اسم ملف PDF بدون .pdf", "اسم الملف")
            If fileName = "" Then
                MsgBox "لم يتم إدخال اسم الملف.", vbExclamation
                Exit Sub
            End If

            ' إنشاء مصنف مؤقت
            Dim tempBook As Workbook
            Set tempBook = Workbooks.Add

            ' نسخ الأوراق للمصنف المؤقت
            For i = 1 To count
                ThisWorkbook.Sheets(printableSheetNames(i)).Copy After:=tempBook.Sheets(tempBook.Sheets.count)
            Next i

            ' حذف الورقة الافتراضية الفارغة
            Application.DisplayAlerts = False
            Do While tempBook.Sheets.count > count
                tempBook.Sheets(1).Delete
            Loop
            Application.DisplayAlerts = True

            ' حفظ كـ PDF
            tempBook.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                fileName:=savePath & "\" & fileName & ".pdf", _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=True

            ' إغلاق المصنف المؤقت بدون حفظ
            tempBook.Close SaveChanges:=False
            MsgBox "تم حفظ ملف PDF بنجاح.", vbInformation
        End If
    Else
        MsgBox "لم يتم تحديد أي ورقة للطباعة أو التصدير.", vbExclamation
    End If

    Application.ScreenUpdating = True
End Sub