كود تصدير pdf ولبس طباعة

[بلانك]

كود تصدير pdf وليس طباعة لجميع الجداول مرة واحدة وبملف واحد وعددها 17 جدول

جدول.xlsm

[بلانك]

Up

 

[بلانك]

Up

[عبدالله بشير عبدالله]

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

اليك  ما طلبت 

Sub ExportCertificatesToSinglePDF()
    Dim lr As Long, i As Long, pageCount As Long
    Dim pdfPath As String, wsMain As Worksheet, tempWS As Worksheet
    Dim tempSheetNames As Collection
    Dim sh As Worksheet

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set wsMain = ThisWorkbook.Sheets("معلمين")
    Set tempSheetNames = New Collection

    wsMain.Range("m2").FormulaR1C1 = "=COUNTA('جدول عام'!R6C1:R22C1)"
    lr = wsMain.Range("m2").Value
    i = 1
    pageCount = 1

    Do Until i > lr
        wsMain.Range("m2").Value = i

        wsMain.Copy After:=Sheets(Sheets.Count)
        Set tempWS = ActiveSheet
        tempWS.Name = "Temp_" & pageCount
        tempWS.PageSetup.PrintArea = "$A$1:$i$37"
        tempSheetNames.Add tempWS.Name

        i = i + 3
        pageCount = pageCount + 1
    Loop

    pdfPath = ThisWorkbook.Path & "\الشهادات.pdf"

    Dim wsArray() As Variant
    ReDim wsArray(1 To tempSheetNames.Count)
    For i = 1 To tempSheetNames.Count
        wsArray(i) = tempSheetNames(i)
    Next i
    ThisWorkbook.Sheets(wsArray).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPath

    For i = 1 To tempSheetNames.Count
        Application.DisplayAlerts = False
        ThisWorkbook.Sheets(tempSheetNames(i)).Delete
        Application.DisplayAlerts = True
    Next i

    wsMain.Select
    wsMain.Range("m2").Value = 1

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox "تم حفظ الشهادات في ملف PDF بنجاح!", vbInformation, "تم الحفظ"
End Sub

تحويل الشهادات الى pdf.xlsm

[بلانك]

بارك الله في عمرك وزادك علما على مساعدة الغير استاذنا عبدالله بشير