Combine multiple PDF files with VBA

[EvdM]

Dear VBA Specialists,

I want to create a macro which merges multiple PDF files, but the amount of files that has to be merged is variable and need to be determined in the excelsheet. So my wish is to gain a VBA code that reads the filenames out of a folder, Somehow select which ones should merged into the same file and let Adobe Acrobat Pro do the rest.

I have achieved to get a code running that reads out a folder and projets the filename and path in the sheet (column A and B). Now should be selected which files belong in the same combined PDF. My best guess is to write down the name of the future merged filename in column C...? And adjust the code to that system. (Example Below)

Filepath 1	File 1	Mergedfile 1
Filepath 2	File 2	Mergedfile 1
Filepath 3	File 3	Mergedfile 1
Filepath 4	File 4	Mergedfile 2
Filepath 5	File 5	Mergedfile 2

Online are some examples of VBA code that could merge PDF files but not exactly working like how I imagine.
This raises the question if it makes sense to let it work how I described over here?

If you can have any advice or can help me out with making this work, that would be very much appreciated!

Kind regards,

Edwin

 

[John_w]

Welccome to MrExcel forums.

Try this macro:

Option Explicit

Public Sub Merge_PDFs()

    Dim PDFfiles As Variant
    Dim i As Long
    Dim PDDocDestination As Object 'Acrobat.CAcroPDDoc
    Dim PDDocSource As Object 'Acrobat.CAcroPDDoc
       
    With ActiveSheet
        PDFfiles = .Range("A2", .Cells(.Rows.Count, "C").End(xlUp)).Value
    End With
   
    'Create Acrobat API objects
   
    Set PDDocDestination = CreateObject("AcroExch.PDDoc")
    Set PDDocSource = CreateObject("AcroExch.PDDoc")
   
    'Loop through rows, opening PDF file in column A & B, merging to and saving as PDF file in column A & C
   
    For i = 1 To UBound(PDFfiles)
        If Right(PDFfiles(i, 1), 1) <> "\" Then PDFfiles(i, 1) = PDFfiles(i, 1) & "\"
        If Dir(PDFfiles(i, 1) & PDFfiles(i, 3)) = vbNullString Then
            'Destination (merged) PDF doesn't exist, so create new file
            PDDocDestination.Create
        Else
            'Open existing destination (merged) PDF
            PDDocDestination.Open PDFfiles(i, 1) & PDFfiles(i, 3)
        End If
        PDDocSource.Open PDFfiles(i, 1) & PDFfiles(i, 2)
        If Not PDDocDestination.InsertPages(PDDocDestination.GetNumPages - 1, PDDocSource, 0, PDDocSource.GetNumPages, 0) Then
            MsgBox "Error merging" & vbCrLf & PDFfiles(i, 1) & PDFfiles(i, 2) & vbCrLf & "to" & vbCrLf & PDFfiles(i, 1) & PDFfiles(i, 3), vbExclamation
        End If
        PDDocSource.Close
        PDDocDestination.Save Acrobat.PDSaveFlags.PDSaveFull, PDFfiles(i, 1) & PDFfiles(i, 3)
        PDDocDestination.Close
    Next
   
    Set PDDocSource = Nothing
    Set PDDocDestination = Nothing

    MsgBox "Done"
   
End Sub

 

[EvdM]

Hi John,

Thank you for taking the time to anwser my questions.
It seems like a decent code that might work, but it isn't working, see issue below.
Do you know what might be the problem over here?

The tool that I've created is filling the Path in column C, Filename in column D and renamed PDF name in column G.
Can I simply change the 1 by a 3, 2 by 4 and 3 by 7?

I've build up my sheet like this for now: (Column A/C)

If I run the code it gives this issue:

Thank you in advance!
Kind regards,
Edwin

 

[John_w]

As described by your OP, my code expects the following:

Column A - path
Column B - PDF file name (including .pdf extension)
Column C - PDF merged file name (including .pdf extension)

with data starting in row 2 of the active sheet.

The tool that I've created is filling the Path in column C, Filename in column D and renamed PDF name in column G.
Can I simply change the 1 by a 3, 2 by 4 and 3 by 7?

Yes, and:

    With ActiveSheet
        PDFfiles = .Range("A2", .Cells(.Rows.Count, "G").End(xlUp)).Value
    End With

and append the ".pdf" extension to every PDFfiles(i,4) and PDFfiles(i,7) reference, for example:

        If Dir(PDFfiles(i, 3) & PDFfiles(i, 4) & ".pdf") = vbNullString Then

 

[EvdM]

Thank you John,

That with the pdf extensions is clear now. The sheet contains a column F (6) that has the filename + extension.
I implemented into the code and will write the Mergedpdf name with the .pdf behind it

Either way does it still gives the same issue as before with this sheet and code:
Any suggestions?

Does this number has to be a 1 or a 3? (I've tried both)" For i = 1 To UBound(PDFfiles) "

Sub MergePDF()

Dim PDFfiles As Variant
Dim i As Long
Dim PDDocDestination As Object 'Acrobat.CAcroPDDoc
Dim PDDocSource As Object 'Acrobat.CAcroPDDoc

With ActiveSheet
PDFfiles = .Range("A2", .Cells(.Rows.Count, "G").End(xlUp)).Value
End With

'Create Acrobat API objects

Set PDDocDestination = CreateObject("AcroExch.PDDoc")
Set PDDocSource = CreateObject("AcroExch.PDDoc")

'Loop through rows, opening PDF file in column A & B, merging to and saving as PDF file in column A & C

For i = 3 To UBound(PDFfiles)
If Right(PDFfiles(i, 3), 3) <> "\" Then PDFfiles(i, 3) = PDFfiles(i, 3) & "\"
If Dir(PDFfiles(i, 3) & PDFfiles(i, 7)) = vbNullString Then
'Destination (merged) PDF doesn't exist, so create new file
PDDocDestination.Create
Else
'Open existing destination (merged) PDF
PDDocDestination.Open PDFfiles(i, 3) & PDFfiles(i, 7)
End If
PDDocSource.Open PDFfiles(i, 3) & PDFfiles(i, 6)
If Not PDDocDestination.InsertPages(PDDocDestination.GetNumPages - 1, PDDocSource, 0, PDDocSource.GetNumPages, 0) Then
MsgBox "Error merging" & vbCrLf & PDFfiles(i, 3) & PDFfiles(i, 6) & vbCrLf & "to" & vbCrLf & PDFfiles(i, 3) & PDFfiles(i, 7), vbExclamation
End If
PDDocSource.Close
PDDocDestination.Save Acrobat.PDSaveFlags.PDSaveFull, PDFfiles(i, 3) & PDFfiles(i, 7)
PDDocDestination.Close
Next

Set PDDocSource = Nothing
Set PDDocDestination = Nothing

MsgBox "Done"

End Sub

 

[John_w]

Does this number has to be a 1 or a 3? (I've tried both)" For i = 1 To UBound(PDFfiles) "

No, because that loops from row 1 of the PDFfiles array to its last row.

In:

    With ActiveSheet
        PDFfiles = .Range("A2", .Cells(.Rows.Count, "G").End(xlUp)).Value
    End With

the A2 and G means the PDFfiles array is loaded starting at cell A2 to the last row in column G.

Therefore if your data starts in row 3 change the A2 to A3, and the code you posted, but with For i = 1 To UBound(PDFfiles), should work.

PS please click the VBA icon in the message editor to add code tags.

 

[EvdM]

Thank you a lot John!

After I added Adobe in the References of the Tools (again) It worked right away!

Is there a way of getting your address to send you a reward for this amazing help?

Kind regards,
Edwin

 

[John_w]

I should have seen that Acrobat.PDSaveFlags.PDSaveFull would require a reference to the Adobe Acrobat Type library. Apart from that, the code uses late binding of the Acrobat objects and therefore you can replace that enumeration name with the value 1 and remove the library reference.

No need for a reward as we are not allowed to receive any kind of payment on this forum.

 

[EvdM]

I guess I could do that but it works so I won't bother to change anything about it
That's very humble of you. Thank you very much and take good care!

 

[phuongnguyenvpvn]

Welccome to MrExcel forums.

Try this macro:

Option Explicit

Public Sub Merge_PDFs()

    Dim PDFfiles As Variant
    Dim i As Long
    Dim PDDocDestination As Object 'Acrobat.CAcroPDDoc
    Dim PDDocSource As Object 'Acrobat.CAcroPDDoc
      
    With ActiveSheet
        PDFfiles = .Range("A2", .Cells(.Rows.Count, "C").End(xlUp)).Value
    End With
  
    'Create Acrobat API objects
  
    Set PDDocDestination = CreateObject("AcroExch.PDDoc")
    Set PDDocSource = CreateObject("AcroExch.PDDoc")
  
    'Loop through rows, opening PDF file in column A & B, merging to and saving as PDF file in column A & C
  
    For i = 1 To UBound(PDFfiles)
        If Right(PDFfiles(i, 1), 1) <> "\" Then PDFfiles(i, 1) = PDFfiles(i, 1) & "\"
        If Dir(PDFfiles(i, 1) & PDFfiles(i, 3)) = vbNullString Then
            'Destination (merged) PDF doesn't exist, so create new file
            PDDocDestination.Create
        Else
            'Open existing destination (merged) PDF
            PDDocDestination.Open PDFfiles(i, 1) & PDFfiles(i, 3)
        End If
        PDDocSource.Open PDFfiles(i, 1) & PDFfiles(i, 2)
        If Not PDDocDestination.InsertPages(PDDocDestination.GetNumPages - 1, PDDocSource, 0, PDDocSource.GetNumPages, 0) Then
            MsgBox "Error merging" & vbCrLf & PDFfiles(i, 1) & PDFfiles(i, 2) & vbCrLf & "to" & vbCrLf & PDFfiles(i, 1) & PDFfiles(i, 3), vbExclamation
        End If
        PDDocSource.Close
        PDDocDestination.Save Acrobat.PDSaveFlags.PDSaveFull, PDFfiles(i, 1) & PDFfiles(i, 3)
        PDDocDestination.Close
    Next
  
    Set PDDocSource = Nothing
    Set PDDocDestination = Nothing

    MsgBox "Done"
  
End Sub

Dear Mr John
Thanks for your posts
now i happened an issue but i don't know what is reason, Could you help me to resolve this case?
Thank you so much!!