Print all external workbooks in a folder location to PDF

[camerong]

Hi guys,

I'm after a VBA macro code that I can have saved in a workbook that, when run by pushing the macro button. Brings up a window where you can select a folder and it will find all excel workbooks in that location and print them to PDF. I would like the Print to pdf to only print used cells and scale it down so that the used columns all are on a single page. Page size A4, portrait. PDF filename to be the same as the excel document printed.

Thanks

 

[OaklandJim]

Do workbooks have one worksheet or are there more than one? If more than one worksheet per workbook then should this print all worksheets or a specific worksheet?

 

[camerong]

Hi OaklandJim,

The workbooks will just have a single worksheet

Thanks

 

[OaklandJim]

I hope that THIS WORKBOOK does what is needed. It always makes the first worksheet in a workbook into a PDF.

Option Base 1


Sub WorkbooksInFolderAsPDFs()

'   Workbok object points to each workbook processed.
    Dim wbToPDF As Workbook
    
'   Worksheet object used to specify which worksheet to make into pdf.
    Dim wsToPDF As Worksheet
    
'   Name of the pdf file to save.
    Dim sFileNamePDF As String
    
'   Name of "thisworkbook" used so this workbook is not made into a pdf.
    Dim sThisworkbookName As String
    
'   Count of files found.
    Dim iFilesFound As Long
    
    Dim iFileIndex As Long
    
'   Path to and name of folder.
    Dim sPathAndFolder As String
    
'   Array that wil hold all file names in a folder.
    Dim asFiles() As String
    
'   Get this file's name...don't want to process it.
    sThisworkbookName = ThisWorkbook.Name
    
'   Get folder from user.
    sPathAndFolder = GetFolderFromUser()
    
'   Put name of all files found in the folder.
    Call FilesListToArray(sPathAndFolder, asFiles)
    
'   Get count of files found.
    iFilesFound = UBound(asFiles)
    
'   Add trailing slash if it is missing.
    If Right(sPathAndFolder, 1) <> "\" Then sPathAndFolder = sPathAndFolder & "\"
    
'   Iterate all files found in the folder.
    For iFileIndex = 1 To iFilesFound
    
    '   Open the next workbook found in the folder.
        Set wbToPDF = Workbooks.Open(sPathAndFolder & asFiles(iFileIndex))
        
'       Only process workbooks if they are not thisworkbook.
        If wbToPDF.Name <> sThisworkbookName _
        Then
        
'           Specify which worksheet to make into a pdf.
            Set wsToPDF = wbToPDF.Worksheets(1)
            
            sFileNamePDF = GetFileNameNoExt(wbToPDF.Name)
        
            With wsToPDF
            
'               Select the first worksheet in the workbook being processed.
                .Select
            
'               Do page setup: 1, portrait, 2. fit to one page, 3. A4.
                With .PageSetup
                    
                    .Orientation = xlPortrait
                    .PaperSize = xlPaperA4
                    .FitToPagesWide = 1
                    .FitToPagesTall = 1
                
                End With
                
                Call PDFWorksheet(wsToPDF, sPathAndFolder, sFileNamePDF)
        
            End With
            
            Application.DisplayAlerts = False
        
            wbToPDF.Close
        
        End If
    
    Next iFileIndex

End Sub

Function GetFolderFromUser() As String
    
    Dim fldr As FileDialog
    
    Dim sItem As String
    
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With

NextCode:
    
    GetFolderFromUser = sItem
    
    Set fldr = Nothing

End Function

Option Explicit
Option Base 1

' ----------------------------------------------------------------
' Procedure Name: FilesListToArray
' Purpose: Get a list of files in a folder. Put it into array.
' Procedure Kind: Sub
' Procedure Access: Public
' Parameter psFolder (String): Folder path -- as string -- containing file(s) to process.
' Parameter pasFiles (String): Array to fill with file names.
' Author: Adapted from code at https://stackoverflow.com/questions/70348103
' Date: 6/3/2023
' ----------------------------------------------------------------
Sub FilesListToArray(psFolder As String, ByRef pasFiles() As String)

    Dim iFileIndex As Long
    
    Dim sFileName As String
    
    Dim sPath As String
    
    Dim sFilter As String
    
    iFileIndex = 1
    
    sPath = psFolder
    
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    
    sFilter = "*.xls*"
    
    sFileName = Dir(sPath, 15)
        
    Do While Len(sFileName)
        
        If LCase(sFileName) Like sFilter Then
        
            ReDim Preserve pasFiles(iFileIndex)
            
            pasFiles(iFileIndex) = sFileName
            
            iFileIndex = iFileIndex + 1
        
        End If
        
        sFileName = Dir
    
    Loop

End Sub

' ----------------------------------------------------------------
' Procedure Name: GetFileNameNoExt
' Purpose: Get file name without extension.
' Procedure Kind: Function
' Procedure Access: Public
' Parameter psFileName (String): Full name of file to process.
' Return Type: String
' Author: Jim
' Date: 6/4/2023
' ----------------------------------------------------------------
Function GetFileNameNoExt(psFileName As String) As String

    Dim iLen As Long
    
    Dim iChar As Long
    
    Dim iLastDotIndex As Long
    
    Dim sCurrentChar As String
        
    iLen = Len(psFileName)
        
    GetFileNameNoExt = "NoFileName"
        
    For iChar = iLen To 1 Step -1
    
        sCurrentChar = Mid(psFileName, iChar, 1)
        If sCurrentChar = "." _
         Then
            iLastDotIndex = iChar
            Exit For
        End If
    
    Next iChar
    
    GetFileNameNoExt = Left(psFileName, iLastDotIndex - 1)

End Function

Option Explicit

' ----------------------------------------------------------------
' Procedure Name: PDFWorksheet
' Purpose: Create a PDF of statement worksheet.
' Procedure Kind: Sub
' Procedure Access: Public
' Parameter pwsSource (Worksheet): The "source" worksheet, => Customer Copy worksheet.
' Parameter psFolderToSaveIn (String): The folder where PDFs are stored: Full path.
' Parameter psName (String): The PDF file's name.
' Author: https://stackoverflow.com/questions/26392482/,
'         Based on code from www.contextures.com
' Date: 10/10/2022
' ----------------------------------------------------------------

Sub PDFWorksheet(pwsSource As Worksheet, psFolderToSaveIn As String, psName As String)

    Dim wbA As Workbook
    
    Dim sTime As String
    
    Dim sSheetName As String
    
    Dim sPath As String
    
    Dim sPDFFileName As String
    
    Dim sFileSpec As String
    
    Dim vFile As Variant
    
    On Error GoTo errHandler
    
    If psFolderToSaveIn = "" Then
      psFolderToSaveIn = Application.DefaultFilePath
    End If
    
'   Add ending slash if it is not there.
    If Right(psFolderToSaveIn, 1) <> "\" Then psFolderToSaveIn = psFolderToSaveIn & "\"
    
'   Create name for the file to be saved. Use parameter psName.
    If UCase(Right(psName, 4)) <> ".PDF" Then psName = psName & ".pdf"
    
'    sPDFFileName = psName
    
    sFileSpec = psFolderToSaveIn & psName
    
'   Delete the file if it already exists.
    On Error Resume Next
    Kill (sFileSpec)
    On Error GoTo 0
    
    pwsSource.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=sFileSpec, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
            
exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file " & psName, vbCritical
    Resume exitHandler
End Sub


'Sub PDFWorksheet(pwsSource As Worksheet, psFolderToSaveIn As String, psName As String)
'
'    Dim wbA As Workbook
'
'    Dim sTime As String
'
'    Dim sSheetName As String
'
'    Dim sPath As String
'
'    Dim sPDFFileName As String
'
'    Dim sFileSpec As String
'
'    Dim vFile As Variant
'
'    On Error GoTo errHandler
'
''   Folder to save in based on parameter value.
'    sPath = psFolderToSaveIn
'
'    If sPath = "" Then
'      sPath = Application.DefaultFilePath
'    End If
'
''   Add ending slash if needed.
'    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
'
''   Create name for the file to be saved. Use parameter psName.
'    If UCase(Right(psName, 4)) <> ".PDF" Then psName = psName & ".pdf"
'
'    sPDFFileName = psName
'
'    sFileSpec = sPath & sPDFFileName
'
''   Delete the file if it already exists.
'    On Error Resume Next
'    Kill (sFileSpec)
'    On Error GoTo 0
'
'    pwsSource.ExportAsFixedFormat _
'        Type:=xlTypePDF, _
'        Filename:=sFileSpec, _
'        Quality:=xlQualityStandard, _
'        IncludeDocProperties:=True, _
'        IgnorePrintAreas:=False, _
'        OpenAfterPublish:=False
'
'exitHandler:
'    Exit Sub
'errHandler:
'    MsgBox "Could not create PDF file " & sPDFFileName
'    Resume exitHandler
'End Sub

 

[camerong]

Thanks @OaklandJim,

Exactly what I was looking for

 

[camerong]

Hi @OaklandJim,

Just tried the code on a few more workbooks and I had the right hand side of the worksheet cut off and printed on another page. Can we please have the code scale it down so that all columns fit on the width of an A4 page?

Thanks

 

[OaklandJim]

I'll need something to work with. Might you provide a link to a file that is causing the problem? Use the link icon above the message area. I told Excel to fit on one page. I'm disappointed that it does not work!

                With .PageSetup
                    
                    .Orientation = xlPortrait
                    .PaperSize = xlPaperA4
                    .FitToPagesWide = 1
                    .FitToPagesTall = 1
                
                End With

 

[camerong]

Hi @OaklandJim,

No worries, see link below:

Shared

Thanks

 

[OaklandJim]

I hope that I fixed that problem. I tried saving the Excel file with Page Layout settings before creating the PDF. For some reason it seems that Excel needs that before Page Layout settings stick. I hope that it is ok to save the excel file with Page Layout settings for one page wide and A4.

New Version

 

[camerong]

Hi @OaklandJim,

Sorry but the new version still seems to be doing the same thing