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