Merge PDF

[safwaty]

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.