تصدير أوراق عمل محددة إلى ملف بي دي إف Export Specific Sheets To PDF

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

أقدم لكم كود يمكنك من خلاله تحديد أوراق عمل محددة لتصديرها إلى ملف PDF واحد ، أي أن الملف الذي سيتم تصديره سيحتوي على أوراق العمل المحددة ، ويمكنك تحديد المسار الذي سيتم تصدير الملف إليه.

بفرض أن لدينا ثلاثة أوراق عمل Sheet1 و Sheet2 و Sheet3 ، والمطلوب تصدير الثلاثة أوراق عمل إلى ملف بي دي إف ، وهذه صورة لأحد أوراق العمل :

إليكم الكود بهذا الشكل :

Sub Export_Specific_Sheets_To_PDF()
    Dim FSO As Object
    Dim S(1) As String
    Dim sNewFilePath As String
    Dim Row As Long
    
    Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
    Set FSO = CreateObject("Scripting.FileSystemObject")
    S(0) = ThisWorkbook.FullName
    
    If FSO.FileExists(S(0)) Then
        S(1) = FSO.GetExtensionName(S(0))
        If S(1) <> "" Then
            S(1) = "." & S(1)
            
            'Change To Suit
            sNewFilePath = ThisWorkbook.Path & "\Exported.pdf"
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sNewFilePath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        End If
    Else
        MsgBox "Error: This Workbook May Be Unsaved. Please Save And Try Again"
    End If
    
    Sheets("Sheet1").Select
    Set FSO = Nothing
    
    MsgBox "All PDF Files Have Been Created", 64
End Sub

لنفترض أن لدينا 5 أوراق عمل والمطلوب تصديرهم لملف PDF واحد بشرط ألا تكون الخلية A1 في ورقة العمل غير فارغة ، يمكن استخدام الكود بهذا الشكل

Sub Export_Specific_Sheets_To_PDF()
    Dim FSO As Object
    Dim S(1) As String
    Dim sNewFilePath As String
    Dim Row As Long
    Dim I As Integer
    Dim prShts As String
    Dim shArr As Variant

    For I = 1 To 5
        If Not IsEmpty(Sheets(I).Range("A1")) Then
            prShts = prShts & Sheets(I).Name & ","
        End If
    Next I

    shArr = Split(Left(prShts, Len(prShts) - 1), ",")
    Sheets(shArr).Select

    Set FSO = CreateObject("Scripting.FileSystemObject")
    S(0) = ThisWorkbook.FullName

    If FSO.FileExists(S(0)) Then
        S(1) = FSO.GetExtensionName(S(0))
        If S(1) <> "" Then
            S(1) = "." & S(1)

            'Change To Suit
            sNewFilePath = ThisWorkbook.Path & "\Exported.pdf"

            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sNewFilePath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        End If
    Else
        MsgBox "Error: This Workbook May Be Unsaved. Please Save And Try Again"
    End If

    Sheets("Sheet1").Select
    Set FSO = Nothing

    MsgBox "PDF File Has Been Created", 64
End Sub

تحميل الملف من هنا

إعداد / ياسر خليل ابو البراء