Merge PDF

Hello,
I come to you for a little help, I have a folder with several hundred PDF files, they are named:

ABC DEF 1234567 GH 111111_111_IJKL MNOPQRSTUVW_X.pdf
ZYXWVUTSRNBY_QPON_MLK JIH 1234567 GF 00000000_0000_EDCBA ZYXWUTSRN.pdf

I want to make a macro to merge the two files, knowing that what changes every time is 1234567
(by recovering one of the two names), and after once merged recover the name of the files in the Excel sheet.
I found a code on your site, it works fine, but it merges all the files with a different name

Sub Main()

Dim DestFile As String

Dim MyPath As String, MyFiles As String
Dim a() As String, i As Long, f As String, Arr

With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "D:\Dropbox\User\All Entities\Financials\Company A, LLC"
.AllowMultiSelect = False
If .Show = False Then Exit Sub
MyPath = .SelectedItems(1)
DoEvents
End With

' Populate the array a() by PDF file names
If Right(MyPath, 1) <> "" Then MyPath = MyPath & ""

'--> ZVI:2018-11-08 Build DestFile using 2 last (sub)folders
Arr = Split(MyPath, "")
If UBound(Arr) > 2 Then DestFile = Arr(UBound(Arr) - 1)
If UBound(Arr) > 3 Then DestFile = Arr(UBound(Arr) - 2) & " - " & DestFile & " - "
DestFile = DestFile & "Financial Statement.pdf"
'<--

ReDim a(1 To 2 ^ 14)
f = Dir(MyPath & "*.pdf")
While Len(f)
If StrComp(f, DestFile, vbTextCompare) Then
i = i + 1
If Not LCase(f) Like "*.pdf" Then f = f & "*.pdf" ' <-- ZVI:2018-11-08
a(i) = f
End If
f = Dir()
Wend

' Merge PDFs
If i Then
ReDim Preserve a(1 To i)
MyFiles = Join(a, vbTab) ' <-- ZVI:2018-12-19
Application.StatusBar = "Merging, please wait ..."
Call MergePDFs(MyPath, MyFiles, DestFile)
Application.StatusBar = False
Else
MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
End If

End Sub

Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf")
' ZVI:2013-08-27
' Reference required: VBE - Tools - References - Acrobat XX.0 Type Library

Dim a As Variant, i As Long, n As Long, ni As Long, p As String
Dim AcroApp As New Acrobat.AcroApp, PartDocs() As Acrobat.CAcroPDDoc

If Right(MyPath, 1) = "" Then p = MyPath Else p = MyPath & ""
a = Split(MyFiles, vbTab) ' <-- ZVI:2018-12-19
ReDim PartDocs(0 To UBound(a))

On Error GoTo exit_
If Len(Dir(p & DestFile)) Then Kill p & DestFile
For i = 0 To UBound(a)
' Check PDF file presence
If Dir(p & a(i)) = "" Then ' <-- ZVI:2018-11-08 Without Trim()
MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled, i=" & i
Exit For
End If
' Open PDF document
Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
PartDocs(i).Open p & a(i) '<--ZVI:2018-11-08 without Trim()
If i Then
' Merge PDF to PartDocs(0) document
ni = PartDocs(i).GetNumPages()
If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled"
PartDocs(i).Close
Set PartDocs(i) = Nothing
Exit Sub
End If
' Calc the number of pages in the merged document
n = n + ni
' Release the memory
PartDocs(i).Close
Set PartDocs(i) = Nothing
Else
' Calc the number of pages in PartDocs(0) document
n = PartDocs(0).GetNumPages()
End If
Next

If i > UBound(a) Then
' Save the merged document to DestFile
If Not PartDocs(0).Save(PDSaveFull, p & DestFile) Then
MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled"
End If
End If

exit_:

' Inform about error/success
If Err Then
MsgBox Err.Description, vbCritical, "Error #" & Err.Number
ElseIf i > UBound(a) Then
MsgBox "The resulting file is created:" & vbLf & p & DestFile, vbInformation, "Done"
End If

' Release the memory
If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
Set PartDocs(0) = Nothing

' Quit Acrobat application
AcroApp.Exit
Set AcroApp = Nothing

End Sub

Thank you in advance for the help you can give me.

Please paste code between code tags. Click the # icon in reply toolbar to insert the tags. It makes code easier to troubleshoot and avoids character translation issues.

I don't understand. You say you have hundreds in a folder but just want to merge just two. I don't know what recover the name of the files means.

The code creates one merged pdf. Change the value of the inputs to suit. e.g.

Code:

---

'Call MergePDFs(MyPath, MyFiles, DestFile)
MergePDFs MyPath, "ABC DEF 1234567 GH 111111_111_IJKL MNOPQRSTUVW_X.pdf" & vbTab & "ZYXWVUTSRNBY_QPON_MLK JIH 1234567 GF 00000000_0000_EDCBA ZYXWUTSRN.pdf", DestFile

---

You can reference a link if needed. I don't think that you can paste the link until 5 posts. You can say post 66468 for example if you referenced this thread though your pasted routine from ZVI would suffice.

Hello,
Thank you for the help you give me
To be more clear: the 2 names that files correspond to the characters of my files saved in my folders
So I have 2 types of PDF files I want to merge by the name of the files knowing that the names of the files are variable and what which remains in common is what I underlined

Example 1:

Bon SAV S013850 du 20190905_1040_PART DEGROOTE_T.pdf
Implantation_Parc_Bon SAV S013850 du 20190905_1040_PART DEGROOTE_T.pdf

Example 2:

Bon SAV S013852 du 20190905_1108_PART BAILLON_T.pdf
Implantation_Parc_Bon SAV S013852 du 20190905_1108_PART BAILLON_T.pdf


Thank you for your help
(sorry for my english google)

Code:

---

Sub Main()

Dim DestFile As String

Dim MyPath As String, MyFiles As String
Dim a() As String, i As Long, f As String, Arr

With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "D:\Dropbox\User\All Entities\Financials\Company A, LLC"
.AllowMultiSelect = False
If .Show = False Then Exit Sub
MyPath = .SelectedItems(1)
DoEvents
End With

' Populate the array a() by PDF file names
If Right(MyPath, 1) <> "" Then MyPath = MyPath & ""

'--> ZVI:2018-11-08 Build DestFile using 2 last (sub)folders
Arr = Split(MyPath, "")
If UBound(Arr) > 2 Then DestFile = Arr(UBound(Arr) - 1)
If UBound(Arr) > 3 Then DestFile = Arr(UBound(Arr) - 2) & " - " & DestFile & " - "
DestFile = DestFile & "Financial Statement.pdf"
'<--

ReDim a(1 To 2 ^ 14)
f = Dir(MyPath & "*.pdf")
While Len(f)
If StrComp(f, DestFile, vbTextCompare) Then
i = i + 1
If Not LCase(f) Like "*.pdf" Then f = f & "*.pdf" ' <-- ZVI:2018-11-08
a(i) = f
End If
f = Dir()
Wend

' Merge PDFs
If i Then
ReDim Preserve a(1 To i)
MyFiles = Join(a, vbTab) ' <-- ZVI:2018-12-19
Application.StatusBar = "Merging, please wait ..."
Call MergePDFs(MyPath, MyFiles, DestFile)
Application.StatusBar = False
Else
MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
End If

End Sub

Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf")
' ZVI:2013-08-27
' Reference required: VBE - Tools - References - Acrobat XX.0 Type Library

Dim a As Variant, i As Long, n As Long, ni As Long, p As String
Dim AcroApp As New Acrobat.AcroApp, PartDocs() As Acrobat.CAcroPDDoc

If Right(MyPath, 1) = "" Then p = MyPath Else p = MyPath & ""
a = Split(MyFiles, vbTab) ' <-- ZVI:2018-12-19
ReDim PartDocs(0 To UBound(a))

On Error GoTo exit_
If Len(Dir(p & DestFile)) Then Kill p & DestFile
For i = 0 To UBound(a)
' Check PDF file presence
If Dir(p & a(i)) = "" Then ' <-- ZVI:2018-11-08 Without Trim()
MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled, i=" & i
Exit For
End If
' Open PDF document
Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
PartDocs(i).Open p & a(i) '<--ZVI:2018-11-08 without Trim()
If i Then
' Merge PDF to PartDocs(0) document
ni = PartDocs(i).GetNumPages()
If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled"
PartDocs(i).Close
Set PartDocs(i) = Nothing
Exit Sub
End If
' Calc the number of pages in the merged document
n = n + ni
' Release the memory
PartDocs(i).Close
Set PartDocs(i) = Nothing
Else
' Calc the number of pages in PartDocs(0) document
n = PartDocs(0).GetNumPages()
End If
Next

If i > UBound(a) Then
' Save the merged document to DestFile
If Not PartDocs(0).Save(PDSaveFull, p & DestFile) Then
MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled"
End If
End If

exit_:

' Inform about error/success
If Err Then
MsgBox Err.Description, vbCritical, "Error #" & Err.Number
ElseIf i > UBound(a) Then
MsgBox "The resulting file is created:" & vbLf & p & DestFile, vbInformation, "Done"
End If

' Release the memory
If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
Set PartDocs(0) = Nothing

' Quit Acrobat application
AcroApp.Exit
Set AcroApp = Nothing

End Sub

---

It looks like you want to merge two files if the 3rd word in each is the same? I guess there could be cases where no 2 files had that or where more than 2 had that.

If you have that 3rd word in an Excel range, that could be another way to handle the files.

I whichever case, once merged, those should be removed from further processing. A dictionary object makes adding and removing the file names easier.

It seems that you want to merge two files if the third word of each is the same?
It's exactly that.

I suppose there could be cases where no file contained this or more than 2 files contained it?
no all the time it's the 3rd word.

In any case, once merged, these must be removed from further processing
Yes I want to recover one of the two names of the files

Thank you

Quote:

---

I suppose there could be cases where no file contained this or more than 2 files contained it?
no all the time it's the 3rd word.

---

What I mean is that one file has a unique 3rd word, two files have the same 3rd word, or three files or more have that same 3rd word.

Quote:

---

Yes I want to recover one of the two names of the files

---

I still don't know what recover means. Maybe if at least two files have the same 3rd word, then write the base filename of the 1st file to a range?

I think that I would call the merged file, that 3rd word. e.g.
"xx yy 123 zz.pdf" and "xx xx 123.pdf", merged to say 123.pdf. I am not sure that I would merge it to the same folder but we can look at that later if needed.

When I get time tonight maybe, I can post a solution.

There are other 3rd party programs that can do the merge as well. e.g. pdftk, pdfill, pdfsam, etc. The main thing is to get the code to get all the files from a folder and then match merge based on 3rd word.

I showed how to use some of those methods in: http://www.vbaexpress.com/forum/show...and-Subfolders

Thank you in advance for your precious help

Since not all have Acrobat, I made a pseudo merge routine with the same name to show if the right inputs were sent to it.

Code:

---

Sub MergePDFsByWord3() 
  Dim d As Object
  'Dim d As Scripting.Dictionary
  Dim i As Integer, b, f
  Dim DestFile As String, MyPath As String, MyFiles As String
  Dim a() As String
 
  MyPath = "C:\Users\lenovo1\Dropbox (Personal)\_Excel\pdf\t"
  With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = MyPath
    .AllowMultiSelect = False
    If .Show = False Then Exit Sub
    MyPath = .SelectedItems(1)
  End With
 
  If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
 
  a = Split(CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
    """" & MyPath & "*.pdf" & """" & " /b").StdOut.ReadAll, vbCrLf)


  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1 'TextCompary=1, BinaryCompare=0
  For i = 1 To UBound(a)
    b = Split(a(i))
    'IF 3rd word exists, add unique word to dictionary:
    If UBound(b) > 1 Then If Not d.Exists(b(2)) Then d.Add b(2), Nothing
  Next i


  b = d.Keys
  If d.Count > 0 Then
    For i = 0 To UBound(b)
      f = Filter(a, " " & b(i), True, vbTextCompare)
      MergePDFs MyPath, Join(f, vbTab), b(i) & " - Financial Statement.pdf"
    Next i
  End If
 
  Set d = Nothing
End Sub


Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf")
  MsgBox "MyPath: " & MyPath & vbLf & vbLf & "MyFiles:" & vbLf & Replace(MyFiles, vbTab, vbLf) & _
    vbLf & vbLf & "DestFile: " & DestFile
End Sub

---

Hello,
thank you everything works fine but would there be a way to cancel the confirmation message for each merger?

Comment out that msgbox line or delete it or change it to debug.print.

thank you everything works fine:thumb:thumb:thumb:thumb