Option Explicit

Private mobjWordApp As Word.Application

Sub Test()
  ProcessDirectory "C:\temp\"
End Sub

Property Get WordApp() As Word.Application
  If mobjWordApp Is Nothing Then
    Set mobjWordApp = CreateObject("Word.Application")
    mobjWordApp.Visible = True
  End If
  Set WordApp = mobjWordApp
End Property

Sub CloseWordApp()
  If Not (mobjWordApp Is Nothing) Then
    On Error Resume Next
    mobjWordApp.Quit
    Set mobjWordApp = Nothing
  End If
End Sub

Function GetWordDocument(FileName As String) As Word.Document
  On Error Resume Next
  Set GetWordDocument = WordApp.Documents.Open(FileName)
  If Err.Number = &H80010105 Then
    CloseWordApp
    On Error GoTo 0
    Set GetWordDocument = WordApp.Documents.Open(FileName)
  End If
End Function

Sub ProcessDirectory(PathName As String)
  Dim fso As New FileSystemObject, objFile As File
  Dim objFolder As Folder, objWordDoc As Object, aSheet As Worksheet
  Const aSheetName As String = "DocTitles"
  
  On Error Resume Next
    Set aSheet = ActiveWorkbook.Sheets(aSheetName)
  On Error GoTo Err_Handler
  If aSheet Is Nothing Then
    Set aSheet = ActiveWorkbook.Sheets.Add
    aSheet.Name = aSheetName
  End If
  aSheet.Range("A1").Value = "Title"
  aSheet.Range("B1").Value = "Filename"

  Set objFolder = fso.GetFolder(PathName)
  For Each objFile In objFolder.Files
    If objFile.Name Like "*.doc*" Then
      Set objWordDoc = GetWordDocument(objFile.Path)
      ProcessDocument objWordDoc, aSheet
      objWordDoc.Close 0, 1
      Set objWordDoc = Nothing
    End If
  Next

Exit_Handler:
  CloseWordApp
  Exit Sub

Err_Handler:
  MsgBox "Error " & Err.Number & ": " & Err.Description
  Resume Exit_Handler
  'Resume Next ' or as above
End Sub

Sub ProcessDocument(objWordDoc As Document, aSheet As Worksheet)
  Dim aRng As Word.Range, sFound As String, iRow As Integer
  Set aRng = objWordDoc.Content
  With aRng.Find
    .ClearFormatting
    .Style = "Title"
    .Text = ""
    If .Execute = True Then
      sFound = aRng.Text
      iRow = aSheet.UsedRange.Rows.Count + 1
      sFound = Trim(Replace(sFound, vbCr, " ")) 'replace paragraph marks with a space
      aSheet.Cells(iRow, 1).Value = sFound
      aSheet.Cells(iRow, 2).Value = objWordDoc.Name
    End If
  End With
End Sub