Sub Combine()
Dim n As Long, PDFfileName As String
n = 1
Do
n = n + 1
PDFfileName = Dir(ThisWorkbook.Path & "firstpdf" & n & ".pdf")
If PDFfileName <> "" Then
'Open the source document that will be added to the destination
objCAcroPDDocSource.Open ThisWorkbook.Path & "pathwithpdfs" & PDFfileName
If objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
MsgBox "Merged " & PDFfileName
Else
MsgBox "Error merging " & PDFfileName
End If
objCAcroPDDocSource.Close
End If
Loop While PDFfileName <> ""
End Sub
'References
'Adobe Acrobat 10.0 Type Library
Option Explicit
Public Sub Merge_PDFs()
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc
Dim objCAcroPDDocSource As Acrobat.CAcroPDDoc
Dim PDFfiles As Range, PDFfile As Range
Dim n As Long
With ActiveSheet
Set PDFfiles = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With
'Create Acrobat API objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
'Open first PDF file and merge other PDF files into it
n = 0
For Each PDFfile In PDFfiles
n = n + 1
If n = 1 Then
objCAcroPDDocDestination.Open PDFfile.Value
Else
objCAcroPDDocSource.Open PDFfile.Value
If Not objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
MsgBox "Error merging " & PDFfile.Value
End If
objCAcroPDDocSource.Close
End If
Next
'Save merged PDF files as a new file
objCAcroPDDocDestination.Save 1, ThisWorkbook.Path & "\Merged PDFs.pdf"
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing
MsgBox "Created " & ThisWorkbook.Path & "\Merged PDFs.pdf"
End Sub
Replace the Set PDFfiles line with:I have a problem, sometimes at the beginning of the range, A2, it may be empty and the macro doesn't work. It works correctly if A2 has any patch, how can I fix this?
Set PDFfiles = .Columns("A").Find(What:="*", After:=.Range("A1"), LookIn:=xlValues)
Set PDFfiles = .Range(PDFfiles, .Cells(.Rows.Count, "A").End(xlUp))
Thanks so much John, it works perfectly, cool!Replace the Set PDFfiles line with:
VBA Code:Set PDFfiles = .Columns("A").Find(What:="*", After:=.Range("A1"), LookIn:=xlValues) Set PDFfiles = .Range(PDFfiles, .Cells(.Rows.Count, "A").End(xlUp))