Option Explicit
Const Q As String = """"
Public Sub Merge_All_School_PDFs()
Dim PDFsTable As ListObject
Dim headerSheet As Worksheet
Dim PDFsFolder As String, inputPDFs As String, FinalMergedPDF As String
Dim i As Long, n As Long
Dim school As String
Dim numPages As Long
Dim command As String
Dim Wsh As Object 'WshShell
Set PDFsTable = ActiveSheet.ListObjects(1)
'Add temporary sheet which will be exported to PDF for each school's 2-page header
Set headerSheet = ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Worksheets(1))
With PDFsTable
PDFsFolder = Left(.DataBodyRange(1, 2).Value, InStrRev(.DataBodyRange(1, 2).Value, "\"))
FinalMergedPDF = PDFsFolder & "All Schools Merged.pdf"
'Create BLANK.pdf which is added to list of PDFs to be merged for input PDFs which have an odd number of pages
headerSheet.Range("A1").ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFsFolder & "BLANK.pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
inputPDFs = ""
school = ""
For i = 1 To .DataBodyRange.Rows.Count
If .DataBodyRange(i, 1).Value <> school Then
'School has changed - update header sheet and export it as PDF with 2 pages
school = .DataBodyRange(i, 1).Value
With headerSheet.Range("C25")
.Clear
.Value = school
.Font.Name = "Calibri"
.Font.Size = 72
.Font.Bold = True
End With
headerSheet.Range("A1:I60").ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFsFolder & school & " HEADER.pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
'Add school header PDF to list of PDFs to be merged
inputPDFs = inputPDFs & Q & school & " HEADER.pdf" & Q & " "
End If
'Get number of pages in this PDF
numPages = GetNumPages(.DataBodyRange(i, 2).Value)
'Add PDF file in column 2 the number of times specified in column 3 to list of PDFs to be merged
For n = 1 To .DataBodyRange(i, 3).Value
inputPDFs = inputPDFs & Q & Mid(.DataBodyRange(i, 2).Value, InStrRev(.DataBodyRange(i, 2).Value, "\") + 1) & Q & " "
If numPages Mod 2 <> 0 Then
'This PDF file has an odd number of pages so add BLANK.pdf to list of PDFs to be merged
inputPDFs = inputPDFs & Q & "BLANK.pdf" & Q & " "
End If
Next
Next
End With
Application.DisplayAlerts = False
headerSheet.Delete
Application.DisplayAlerts = True
'Merge all input PDFs with PDFtk Server cat command
command = "CD /D " & Q & PDFsFolder & Q & " & PDFtk " & inputPDFs & "cat output " & Q & FinalMergedPDF & Q
Debug.Print command
Set Wsh = New WshShell
Wsh.Run "cmd /c " & command, 0, True
'Delete all the school header PDFs and BLANK.pdf
Wsh.Run "cmd /c DEL " & Q & PDFsFolder & "* HEADER.pdf" & Q, 0, True
Wsh.Run "cmd /c DEL " & Q & PDFsFolder & "BLANK.pdf" & Q, 0, True
MsgBox "Created " & FinalMergedPDF, vbInformation
End Sub
Private Function GetNumPages(PDFfullName As String) As Long
Dim Wsh As Object 'WshShell
Dim dataFile As String
Dim command As String
Dim fileNum As Integer
Dim allText As String
'Run PDFtk dump_data command to get number of pages in this PDF
dataFile = Left(PDFfullName, InStrRev(PDFfullName, "\")) & "dump_data.txt"
command = "PDFtk " & Q & PDFfullName & Q & " dump_data output " & Q & dataFile & Q
Set Wsh = CreateObject("WScript.Shell") 'New WshShell
Wsh.Run "cmd /c " & command, 0, True
fileNum = FreeFile
Open dataFile For Input As fileNum
allText = Input(LOF(fileNum), fileNum)
Close fileNum
GetNumPages = Split(Split(allText, "NumberOfPages: ")(1), vbCrLf)(0)
Kill dataFile
End Function
