Save multiple PDF files in shorter time
2011-11-01 Printing 2 673
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