Export Excel To PDF

ExportCrop

A member over on one of the LinkedIn Excel Groups had a question about how to export 1 to several worksheets from an Excel Workbook to a pdf file.

Below is the method I use to load a Sheets Array from the list the user defined on a worksheet. There are other ways to do this such as based on the ColorIndex of the tab, some character in the name of the worksheet or the code name of the worksheet.

Option Explicit
    
Sub ExportXLToPDF()

    'Comments:
    'Assume list of worksheets to be included in output are listed in Column 1 on "List"

    Dim wb                  As Workbook
    Dim ws                  As Worksheet
    Dim Arr()               As String
    Dim MaxRows             As Long
    Dim i                   As Long
    Dim strPath             As String
    Dim strFileName         As String
    Const strEXTENSION      As String = ".pdf"
    
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("List")
    
    'User - where to save the output file
        strPath = GetFolder & "\"
        
    'User - what to name the output file
        strFileName = GetUserInput(strPrompt:="Please enter a name for the output file", _
                                   strTitle:="File Name")
        
    'Assume list to be included in sheets array in on worksheet named list in Column 1 beginning in Row 1
    'Total number of rows is dynamic
        MaxRows = GetRows(ws:=ws)
        
    'Redim the array to hold the name of the worksheets
        ReDim Preserve Arr(1 To MaxRows)
    
    'Load the list of sheets to be included into the array
        For i = 1 To MaxRows
            Arr(i) = ws.Cells(i, 1).Value
        Next i
        
    'Select the sheets array
        Sheets(Arr).Select
 
    'Export to the sheets array to pdf
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                        Filename:=strPath & strFileName & strEXTENSION, _
                                        Quality:=xlQualityStandard, _
                                        IncludeDocProperties:=True, _
                                        IgnorePrintAreas:=False, _
                                        OpenAfterPublish:=False
                    
    'Tidy up
        'Erase arrays
            Erase Arr
        
        'Destroy objects
            Set ws = Nothing
            Set wb = Nothing
End Sub

And the functions:


Public Function GetRows(ws As Worksheet) As Long
 
    Dim r       As Long
     
    With ws
        r = .Cells(Rows.Count, 1).End(xlUp).Row
        GetRows = r
    End With
     
End Function

Public Function GetUserInput(strPrompt As String, _
                             strTitle As String) As String
      
    Dim strUserInput As String
      
    strUserInput = InputBox(Prompt:=strPrompt, _
                            Title:=strTitle)
                              
    GetUserInput = strUserInput
  
End Function

Public Function GetFolder() As String
  
    Dim fd As FileDialog
    Dim strFolderName As String
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
      
    With fd
        .Title = "Please select a folder"
        .AllowMultiSelect = False
        .Show
        strFolderName = .SelectedItems(1)
    End With
  
    GetFolder = strFolderName
      
    Set fd = Nothing
End Function
,
Trackback

no comment untill now

Add your comment now