Save multiple PDF files in shorter time

 2011-11-01    Printing    2    137

OK, no magic involved in this tip. Saving a worksheet as PDF file will take some time, no matter what. You can't do much about that, but when you are saving many worksheets as PDF files you want this process to go as quickly as possible. I was going to save around 3000 PDF files, and suddenly realized that it took quite a long time to save each file, almost 30 seconds, despite the result file being quite small. I assumed that this was because I tried to save the files to a network drive, so I changed the target folder to a local folder on my computer. To my big surprise this did not help at all, the time used to save each PDF document did not change. Then I realized that when saving a PDF file, Excel was probably "printing" it first before saving the result, and this meant that Excel was communicating with the active printer. Since the active printer in this case was a network printer, I tried to change the active printer to a local printer, one that was connected to my laptop. I tested to create some PDF files again, and this time the process of saving each PDF file used around 2 seconds, both when I saved them to a network folder and to a local folder. Below are a few example macros, one showing how you can temporarily change from a network printer before saving many PDF documents, and then restoring the original printer afterwards.

Sub TestSaveAsPDF_CreateFew()
' create one or a few PDF files like this
Dim strFolder As String, strFile As String
    ThisWorkbook.Activate
    If Len(ThisWorkbook.Path) = 0 Then Exit Sub
    
    ' determine the target folder for the pdf files
    strFolder = ThisWorkbook.Path & Application.PathSeparator
    
    ' delete any existing dummy pdf files created earlier
    If Len(Dir("Test_*.pdf")) > 0 Then
        On Error Resume Next
        Kill "Test_*.pdf"
        On Error GoTo 0
    End If
    
    With ThisWorkbook
        strFile = strFolder & "Test_" & .Worksheets(1).Name & ".pdf"
        Application.StatusBar = "Saving file: " & strFile
        If Not SaveAsPDF(.Worksheets(1), strFile, True) Then
            MsgBox "Failed to export worksheet to PDF!", vbInformation
        End If
    End With
    Application.StatusBar = False
End Sub

Sub TestSaveAsPDF_CreateMultiple()
' create multiple pdf files like this
Dim strFolder As String, strFile As String
Dim i As Long, strPrinter As String
    ThisWorkbook.Activate
    If Len(ThisWorkbook.Path) = 0 Then Exit Sub
    
    ' determine the target folder for the pdf files
    strFolder = ThisWorkbook.Path & Application.PathSeparator
    
    ' delete any existing dummy pdf files created earlier
    If Len(Dir("Test_*.pdf")) > 0 Then
        On Error Resume Next
        Kill "Test_*.pdf"
        On Error GoTo 0
    End If
    
    ' save the current active printer
    strPrinter = Application.ActivePrinter
    ' change from a network printer to a local printer
    ' this will speed up the process of creating many PDF documents
    ' you can use any local printer, the one below gives a decent output quality
    Application.ActivePrinter = "Microsoft XPS Document Writer on Ne01:"
    With ThisWorkbook
        For i = 1 To 25 ' count of pdf files to create
            strFile = strFolder & "Test_" & .Worksheets(1).Name & "_" & Format(i, "000") & ".pdf"
            Application.StatusBar = "Saving file: " & strFile
            If Not SaveAsPDF(.Worksheets(1), strFile, False) Then
                MsgBox "Failed to export worksheet to PDF!", vbInformation
                Exit For ' end loop
            End If
        Next i
    End With
    ' restore the original active printer
    Application.ActivePrinter = strPrinter
    Application.StatusBar = False
End Sub

Function SaveAsPDF(ws As Worksheet, strTargetFile As String, Optional blnOpenAfter As Boolean = False) As Boolean
    SaveAsPDF = False
    If ws Is Nothing Then Exit Function ' no worksheet
    If Len(strTargetFile) < 6 Then Exit Function ' no filename
    If Len(Dir(strTargetFile)) > 0 Then Exit Function ' file exists
    
    SaveAsPDF = True
    On Error GoTo ErrorSavingAsPDF
    ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strTargetFile, Quality:=xlQualityMinimum, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=blnOpenAfter
    On Error GoTo 0
    Exit Function
    
ErrorSavingAsPDF:
    SaveAsPDF = False
    Resume Next
End Function