Sub FindReplaceInWord(ByVal filePath As String)
'Add a reference to the Microsoft Forms 2.0 Object Library
Dim wdApp As Object, wdDoc As Object, Sctn As Object, HdFt As Object
Dim criteriaSheet As Worksheet, lastRow As Long, i As Long, StrFnd as String

' Open Word application
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = False

' Open Word document
On Error Resume Next
Set wdDoc = wdApp.Documents.Open(filePath)
If wdDoc Is Nothing Then
  Debug.Print "ERROR: Could not open document. Check if file exists."
  wdApp.Quit: Exit Sub
End If
On Error GoTo 0

'Initialize Microsoft Forms 2.0 Object Library
Dim DataObj As New MSForms.DataObject

' Reference criteria sheet
Set criteriaSheet = ThisWorkbook.Sheets("Table 1")
lastRow = criteriaSheet.Cells(criteriaSheet.Rows.Count, 1).End(xlUp).Row

' Process Document body, then headers & footers in each Section
For i = 1 To lastRow
  DataObj.SetText ActiveSheet.Cells(i, 2).Text: DataObj.PutInClipboard
  StrFnd = criteriaSheet.Cells(i, 1).Value
  With wdDoc.Content.Find
    .Text = StrFnd
    .Replacement.Text = "^c"
    .Forward = True
    .Wrap = 1
    .MatchCase = False
    .MatchWholeWord = False
    .Execute Replace:=2
  End With
  ' Process headers **without deleting formatting**
  For Each Sctn In wdDoc.Sections
    For Each HdFt In Sctn.Headers
      If HdFt.Exists Then HdFt.Range.Find.Execute Replace:=2
    Next
    For Each HdFt In Sctn.Footers
      If HdFt.Exists Then HdFt.Range.Find.Execute Replace:=2
  Next
Next
wdDoc.Close True: wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set criteriaSheet = Nothing
Debug.Print "Finished Find & Replace in: " & filePath
End Sub