Combine multiple PDF files with VBA

EvdM

New Member
Joined
Dec 2, 2020
Messages
7
Office Version
  1. 365
Platform
  1. Windows
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 1File 1Mergedfile 1
Filepath 2File 2Mergedfile 1
Filepath 3File 3Mergedfile 1
Filepath 4File 4Mergedfile 2
Filepath 5File 5Mergedfile 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
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,752
Welccome to MrExcel forums.

Try this macro:
VBA Code:
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
 
Solution

EvdM

New Member
Joined
Dec 2, 2020
Messages
7
Office Version
  1. 365
Platform
  1. Windows
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)
1607002213036.png

If I run the code it gives this issue:
1607002114420.png


1607002139040.png


Thank you in advance!
Kind regards,
Edwin
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,752
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:
VBA Code:
    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:
VBA Code:
        If Dir(PDFfiles(i, 3) & PDFfiles(i, 4) & ".pdf") = vbNullString Then
 

EvdM

New Member
Joined
Dec 2, 2020
Messages
7
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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) "

1607006431019.png


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
 

Attachments

  • 1607006318030.png
    1607006318030.png
    50.2 KB · Views: 5

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,752
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:
VBA Code:
    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

New Member
Joined
Dec 2, 2020
Messages
7
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,752
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

New Member
Joined
Dec 2, 2020
Messages
7
Office Version
  1. 365
Platform
  1. Windows
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!
 

Watch MrExcel Video

Forum statistics

Threads
1,129,698
Messages
5,637,879
Members
416,987
Latest member
XDee

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top