As an alternative, both documents have the title in Section 1 and that title is in 16 point TNR font. If that is true for all the documents you wish to process, you could use the following function to grab the paragraphs in question.
Function GetTitle(oDoc As Document) As String
'Graham Mayor - https://www.gmayor.com - Last updated - 19 Mar 2021
Dim oRng As Range
Dim sTitle As String
Dim i As Integer
sTitle = ""
For i = 1 To oDoc.Sections(1).Range.Paragraphs.Count
Set oRng = oDoc.Sections(1).Range.Paragraphs(i).Range
If oRng.Font.Size = 16 Then
sTitle = sTitle & oRng.Text
End If
Next i
GetTitle = sTitle
Set oRng = Nothing
End Function
You can then loop through the documents and process the titles however you wish e.g.
Sub BatchTitles()
'Graham Mayor - https://www.gmayor.com - Last updated - 19 Mar 2021
Dim strFile As String
Dim strPath As String
Dim oDoc As Document, oNewDoc As Document
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select folder and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User", , "List Folder Contents"
Exit Sub
End If
strPath = fDialog.SelectedItems.Item(1)
Do Until Right(strPath, 1) = Chr(92)
strPath = strPath & Chr(92)
Loop
End With
strFile = Dir$(strPath & "*.docx")
Set oNewDoc = Documents.Add
While strFile <> ""
Set oDoc = Documents.Open(strPath & strFile)
oNewDoc.Range.InsertAfter GetTitle(oDoc) & vbCr
oDoc.Close SaveChanges:=wdDoNotSaveChanges
strFile = Dir$()
Wend
lbl_Exit:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set fDialog = Nothing
Exit Sub
End Sub