Copying Multiple Versions of the same Excel Page into one PDF - vba

Question

I have a one page excel file that changes based on a drop down selection. I need to be able to export each data set into one PDF. So, I am looking for a macro that would loop through each selection in the drop down menu and have each of those data sets save into a multi page PDF file.
My thought would be to create the loop and have each version saved as a temporary worksheet. Then I could use
ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\tempo.pdf", Quality:= xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
to save all the sheets as one PDF but then I would need to delete all the temp files.
Thanks,
Chris

Answer 1

I suggest exporting them all individually to PDF into a temp directory, stitching them together using Adobe's COM automation library (assuming you have Pro), then deleting the temp folder.
Public Sub JoinPDF_Folder(ByVal strFolderPath As String, ByVal strOutputFileName As String)
On Error GoTo ErrHandler:
Dim AcroExchPDDoc As Object, _
AcroExchInsertPDDoc As Object
Dim strFileName As String
Dim iNumberOfPagesToInsert As Integer, _
iLastPage As Integer
Set AcroExchPDDoc = CreateObject("AcroExch.PDDoc")
Dim strFirstPDF As String
' Get the first pdf file in the directory
strFileName = Dir(strFolderPath + "*.pdf", vbNormal)
strFirstPDF = strFileName
' Open the first file in the directory
If Not (AcroExchPDDoc.Open(strFolderPath & strFileName)) Then
Err.Raise 55555, "JoinPDF_Folder", "Could not open PDF for joining"
End If
' Get the name of the next file in the directory [if any]
If strFileName <> "" Then
strFileName = Dir
' Start the loop.
Do While strFileName <> ""
' Get the total pages less one for the last page num [zero based]
iLastPage = AcroExchPDDoc.GetNumPages - 1
Set AcroExchInsertPDDoc = CreateObject("AcroExch.PDDoc")
' Open the file to insert
If Not (AcroExchInsertPDDoc.Open(strFolderPath & strFileName)) Then
Err.Raise 55555, "JoinPDF_Folder", "Could not open PDF for joining"
End If
' Get the number of pages to insert
iNumberOfPagesToInsert = AcroExchInsertPDDoc.GetNumPages
' Insert the pages
AcroExchPDDoc.InsertPages iLastPage, AcroExchInsertPDDoc, 0, iNumberOfPagesToInsert, True
' Close the document
AcroExchInsertPDDoc.Close
' Delete the document
Kill strFolderPath & strFileName
' Get the name of the next file in the directory
strFileName = Dir
Loop
' Save the entire document as the strOutputFileName using SaveFull [0x0001 = &H1]
If Not (AcroExchPDDoc.Save(PDSaveFull, strOutputFileName)) Then
Err.Raise 55556, "JoinPDF_Folder", "Could not save joined PDF"
End If
End If
' Close the PDDoc
AcroExchPDDoc.Close
Kill strFolderPath & strFirstPDF
CallStack.Pop
Exit Sub
ErrHandler:
GlobalErrHandler
End Sub

Answer 2

Here was my solution:
Sub LoopThroughDD()
'Created by Chrismas007
Dim DDLCount As Long
Dim TotalDDL As Long
Dim CurrentStr As String
TotalDDL = Sheets("Report").DropDowns("Drop Down 10").ListCount
'Loops through DropDown stores
For DDLCount = 1 To TotalDDL
Sheets("Report").DropDowns("Drop Down 10").Value = DDLCount
CurrentStr = "Report" & DDLCount
'Creates a copy of each store and pastes them in a new worksheet
Sheets.Add(After:=Sheets(Worksheets.Count)).Name = "Report" & DDLCount
Sheets("Report").Columns("D:V").Copy
Sheets(CurrentStr).Columns("A:S").Insert Shift:=xlToRight
Sheets(CurrentStr).Range("A1:S98").Select
Selection.Copy
Sheets(CurrentStr).Range("A1:S98").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Sheets(CurrentStr).PageSetup.PrintArea = "$A$1:$S$98"
'Sets worksheet to one page
With Sheets(CurrentStr).PageSetup
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.FitToPagesWide = 1
.FitToPagesTall = 1
.Zoom = False
.CenterHorizontally = True
.CenterVertically = True
End With
Next DDLCount
'Because only visable worksheets will be captured on PDF dump, need to hide temporarily
Sheets("Report").Visible = False
Dim TheOS As String
Dim dd As DropDown
'Going to name the file as the rep name so grabbing that info here
Set dd = Sheets("Report").DropDowns("Drop Down 2")
TheOS = Application.OperatingSystem
'Select all visible worksheets and export to PDF
Dim ws As Worksheet
For Each ws In Sheets
If ws.Visible Then ws.Select (False)
Next
If InStr(1, TheOS, "Windows") > 0 Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & dd.List(dd.ListIndex), Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Else
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & ":" & dd.List(dd.ListIndex), Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
End If
'Unhide our original worksheet
Sheets("Report").Visible = True
TotalDDL = Sheets("Report").DropDowns("Drop Down 10").ListCount
'Delete all temp worksheets
For DDLCount = 1 To TotalDDL
CurrentStr = "Report" & DDLCount
Application.DisplayAlerts = False
Sheets(CurrentStr).Delete
Application.DisplayAlerts = True
Next DDLCount
DDLCount = Empty
End Sub