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 WkSht As Worksheet, r As Long, StrFnd As String, StrRep 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 WkSht = ThisWorkbook.Sheets("Table 1")

' Process Document body, then headers & footers in each Section
For r = 1 To WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
  StrFnd = WkSht.Cells(r, 1).Value: StrRep = WkSht.Cells(r, 2).Value
  If Len(StrRep) > 255 Then DataObj.SetText StrRep: DataObj.PutInClipboard: StrRep = "^c"
  With wdDoc.Content.Find
    .Text = StrFnd
    .Replacement.Text = StrRep
    .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
Next
wdDoc.Close True: wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Debug.Print "Finished Find & Replace in: " & filePath
End Sub