Using VBA, create one single PDF of all the worksheets combined except for two worksheets

105 Views Asked by At

I`m trying to save all the worksheets from the workbook as one single pdf (all sheets combined in one pdf) except for two worksheets that are not needed in the pdf which have the names of "Raw" and "Tables". I have one code, but when I run it I do not see the saved file even though the code runs successfully. What am I doing wrong or is there an easier way to tacklethis? Thanks!

Sub CombineWorksheetsAsPDF()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim saveFolderPath As String
    Dim pdfFileName As String
    Dim wsNamesToExclude As String
    Dim wsNamesArray As Variant
    Dim i As Long
    Dim pdfFilePath As String
    saveFolderPath = "C:\Users\j\Documents" ' Change this!!!!!
    Application.ScreenUpdating = False
    Set wb = ActiveWorkbook
    pdfFileName = Left(wb.Name, InStrRev(wb.Name, ".")) & ".pdf"
    wsNamesToExclude = "Raw,Tables" ''exclude these tabs
    wsNamesArray = Split(wsNamesToExclude, ",")
    pdfFilePath = saveFolderPath & pdfFileName
    If Dir(pdfFilePath) <> "" Then
        Kill pdfFilePath
    End If
    
    For Each ws In wb.Sheets
        If Not IsInArray(ws.Name, wsNamesArray) Then
            ws.Select
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfFilePath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
        End If
    Next ws
    Application.ScreenUpdating = True
    
    MsgBox "PDF seved in: " & saveFolderPath, vbInformation
End Sub

Function IsInArray(ByVal valToBeFound As String, arr As Variant) As Boolean
    Dim element As Variant
    On Error Resume Next
    IsInArray = (UBound(Filter(arr, valToBeFound)) > -1)
    On Error GoTo 0
End Function
1

There are 1 best solutions below

0
VBasic2008 On

Export Sheets to Single PDF

Sub ExportSheetsToSinglePDF()
    
    Const PROC_TITLE As String = "Export Sheets to Single PDF"
    Const SAVE_PATH As String = "C:\Users\j\Documents"
    Const EXCLUSIONS_LIST As String = "Raw,Tables"
    
    Dim wb As Workbook: Set wb = ActiveWorkbook
    ' if it's the workbook containing this code, use 'ThisWorkbook' instead.
    
    Dim Exclusions() As String: Exclusions = Split(EXCLUSIONS_LIST, ",")
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Dim sh As Object
    
    For Each sh In wb.Sheets
        If IsError(Application.Match(sh.Name, Exclusions, 0)) Then
            dict(sh.Name) = Empty
        End If
    Next sh
    
    If dict.Count = 0 Then
        MsgBox "No sheets found.", vbCritical, PROC_TITLE
        Exit Sub
    End If
    
    Dim PdfFileName As String:
    PdfFileName = Left(wb.Name, InStrRev(wb.Name, ".")) & "pdf"
    
    Dim pSep As String: pSep = Application.PathSeparator
    
    Dim PdfFilePath As String: PdfFilePath = SAVE_PATH
    If Right(PdfFilePath, 1) <> pSep Then PdfFilePath = PdfFilePath & pSep
    PdfFilePath = PdfFilePath & PdfFileName
    
    wb.Sheets(dict.Keys).Copy
    
    With Workbooks(Workbooks.Count)
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFilePath, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
        .Close SaveChanges:=False
    End With
    
    Dim Msg As Long:
    
    Msg = MsgBox("Sheets exported to """ & PdfFileName & """ located in """ _
        & SAVE_PATH & """!" & vbLf & vbLf _
        & "Do you want to explore the destination path?", _
        vbQuestion + vbYesNo + vbDefaultButton2, PROC_TITLE)
    If Msg = vbYes Then
        wb.FollowHyperlink SAVE_PATH
    End If
    
End Sub