VBA Merge PDFs with Similar File Name

[Chrisjschndr]

I have a macro that will scroll through a range and fill in a form and then export that as PDF to the folder that the Excel file is in. The macro adds "TB" to the end of the file name - the TB means it is basically a cover page. I then paste all the regular files in the folder. This part all works perfect. I need one more part though to complete my automation cycle.

How do I write the VBA to use Acrobat to add the TB to the front of the other file? I found the other posts that had the code to initialize Acrobat, but really need to know how to loop through the folder. I plan on using Adobe but don't have it on the computer this screenshot is from - just ignore the Foxit part of the screenshot.

Any help is much appreciated.

 

[John_w]

It's not totally clear which PDFs you want to merge. I assume you want to merge each 'TB' PDF with its corresponding 'main' PDF, i.e. 8110-100-01-O TB.pdf and 8110-100-01-O.pdf, 8110-123-08-O TB.pdf and 8110-123-08-O.pdf, etc. Try this macro, which requires you set a reference, via Tools -> References in the VBA editor, to Adobe Acrobat nn.0 Type Library.

Public Sub Merge_PDF_Pairs_In_Folder()

    Dim PDDocDestination As Acrobat.CAcroPDDoc
    Dim PDDocSource As Acrobat.CAcroPDDoc
    Dim PDFcovers As Collection
    Dim PDFsFolder As String, PDFfile As String
    Dim i As Long
    
    PDFsFolder = ThisWorkbook.Path & "\"
    
    'Create Acrobat API objects
    
    Set PDDocDestination = New AcroPDDoc    'CreateObject("AcroExch.PDDoc")
    Set PDDocSource = New AcroPDDoc         'CreateObject("AcroExch.PDDoc")
    
    'Create collection of PDF cover pages
    
    Set PDFcovers = New Collection
    PDFfile = Dir(PDFsFolder & "* TB.pdf")
    While PDFfile <> vbNullString
        PDFcovers.Add PDFfile
        PDFfile = Dir
    Wend
    
    'Merge each cover with its corresponding main PDF
    
    For i = 1 To PDFcovers.Count
        PDFfile = Replace(PDFcovers(i), " TB", "")
        If Dir(PDFsFolder & PDFfile) <> vbNullString Then
            PDDocDestination.Open PDFsFolder & PDFcovers(i)
            PDDocSource.Open PDFsFolder & PDFfile
            If Not PDDocDestination.InsertPages(PDDocDestination.GetNumPages - 1, PDDocSource, 0, PDDocSource.GetNumPages, 0) Then
                MsgBox "Error merging" & vbCrLf & PDFcovers(i) & vbCrLf & "and" & vbCrLf & PDFfile, vbExclamation
            End If
            PDDocSource.Close
            PDDocDestination.Save Acrobat.PDSaveFlags.PDSaveFull, PDFsFolder & Replace(PDFfile, ".pdf", " FINAL.pdf", Compare:=vbTextCompare)
            PDDocDestination.Close
        End If
    Next
    
    Set PDDocSource = Nothing
    Set PDDocDestination = Nothing

    MsgBox "Done"
    
End Sub

 

[Chrisjschndr]

Sorry for not being clear enough. That is exactly what I need, merge the TB.

 

[Chrisjschndr]

I did a step through and it seems to have a problem with the file name. The references has Adobe checked. Files were definitely in the path folder. Any further help is much appreciated!

 

[John_w]

Is the path a network folder, i.e. "\\server\folder\path\"?

 

[Chrisjschndr]

It looks like it is. Set up to OneDrive atleast. I thought it wasn't because it is on my desktop but the filepath shows OneDrive.

 

[John_w]

Try this version, using FileSystemObject, instead of the native VBA Dir function, to loop through the files.

Public Sub Merge_PDF_Pairs_In_Folder()

    Dim FSO As Object 'Scripting.FileSystemObject
    Dim FSfile As Object 'Scripting.File
    Dim PDDocDestination As Acrobat.CAcroPDDoc
    Dim PDDocSource As Acrobat.CAcroPDDoc
    Dim PDFsFolder As String, PDFmainFile As String
    
    PDFsFolder = ThisWorkbook.Path & "\"
    If Right(PDFsFolder, 1) <> "\" Then PDFsFolder = PDFsFolder & "\"
    
    'Create Acrobat API objects
    
    Set PDDocDestination = New AcroPDDoc    'CreateObject("AcroExch.PDDoc")
    Set PDDocSource = New AcroPDDoc         'CreateObject("AcroExch.PDDoc")
    
    'Merge each cover with its corresponding main PDF
    
    Set FSO = CreateObject("Scripting.FileSystemObject") 'New Scripting.FileSystemObject
    
    For Each FSfile In FSO.GetFolder(PDFsFolder).Files
    
        If UCase(FSfile.Name) Like "* TB.PDF" Then
        
            PDFmainFile = FSfile.ParentFolder & "\" & Replace(FSfile.Name, " TB", "", Compare:=vbTextCompare)
        
            If FSO.FileExists(PDFmainFile) Then
                PDDocDestination.Open FSfile.Path
                PDDocSource.Open PDFmainFile
                If Not PDDocDestination.InsertPages(PDDocDestination.GetNumPages - 1, PDDocSource, 0, PDDocSource.GetNumPages, 0) Then
                    MsgBox "Error merging" & vbCrLf & FSfile.Path & vbCrLf & "and" & vbCrLf & PDFmainFile, vbExclamation
                End If
                PDDocSource.Close
                PDDocDestination.Save Acrobat.PDSaveFlags.PDSaveFull, PDFsFolder & Replace(PDFmainFile, ".pdf", " FINAL.pdf", Compare:=vbTextCompare)
                PDDocDestination.Close
            End If
            
        End If
        
    Next
    
    Set PDDocSource = Nothing
    Set PDDocDestination = Nothing

    MsgBox "Done"
    
End Sub

 

[Chrisjschndr]

Will

Try this version, using FileSystemObject, instead of the native VBA Dir function, to loop through the files.

Public Sub Merge_PDF_Pairs_In_Folder()

    Dim FSO As Object 'Scripting.FileSystemObject
    Dim FSfile As Object 'Scripting.File
    Dim PDDocDestination As Acrobat.CAcroPDDoc
    Dim PDDocSource As Acrobat.CAcroPDDoc
    Dim PDFsFolder As String, PDFmainFile As String
   
    PDFsFolder = ThisWorkbook.Path & "\"
    If Right(PDFsFolder, 1) <> "\" Then PDFsFolder = PDFsFolder & "\"
   
    'Create Acrobat API objects
   
    Set PDDocDestination = New AcroPDDoc    'CreateObject("AcroExch.PDDoc")
    Set PDDocSource = New AcroPDDoc         'CreateObject("AcroExch.PDDoc")
   
    'Merge each cover with its corresponding main PDF
   
    Set FSO = CreateObject("Scripting.FileSystemObject") 'New Scripting.FileSystemObject
   
    For Each FSfile In FSO.GetFolder(PDFsFolder).Files
   
        If UCase(FSfile.Name) Like "* TB.PDF" Then
       
            PDFmainFile = FSfile.ParentFolder & "\" & Replace(FSfile.Name, " TB", "", Compare:=vbTextCompare)
       
            If FSO.FileExists(PDFmainFile) Then
                PDDocDestination.Open FSfile.Path
                PDDocSource.Open PDFmainFile
                If Not PDDocDestination.InsertPages(PDDocDestination.GetNumPages - 1, PDDocSource, 0, PDDocSource.GetNumPages, 0) Then
                    MsgBox "Error merging" & vbCrLf & FSfile.Path & vbCrLf & "and" & vbCrLf & PDFmainFile, vbExclamation
                End If
                PDDocSource.Close
                PDDocDestination.Save Acrobat.PDSaveFlags.PDSaveFull, PDFsFolder & Replace(PDFmainFile, ".pdf", " FINAL.pdf", Compare:=vbTextCompare)
                PDDocDestination.Close
            End If
           
        End If
       
    Next
   
    Set PDDocSource = Nothing
    Set PDDocDestination = Nothing

    MsgBox "Done"
   
End Sub

Will do. Thanks for your patience.

 

[Chrisjschndr]

at

"For Each FSfile In FSO.GetFolder(PDFsFolder).Files" I got Error Filepath not found. Is there a way I can just select the folder?

 

[John_w]

Is there a way I can just select the folder?

Replace:

    PDFsFolder = ThisWorkbook.Path & "\"
    If Right(PDFsFolder, 1) <> "\" Then PDFsFolder = PDFsFolder & "\"

with:

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select PDFs folder"
        .InitialFileName = ThisWorkbook.Path
        If .Show Then
            PDFsFolder = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With