Sub FindReplaceInWord(ByVal filePath As String)
    Dim wdApp As Object, wdDoc As Object
    Dim criteriaSheet As Worksheet
    Dim replaceText As Variant, replaceValue As Variant
    Dim lastRow As Long, i As Integer
    Dim section As Object, header As Object, footer As Object

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

    ' Open Word document
    Debug.Print "Opening document: " & filePath
    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

    ' Reference criteria sheet
    Debug.Print "Loading find-and-replace criteria from worksheet..."
    Set criteriaSheet = ThisWorkbook.Sheets("Table 1")
    lastRow = criteriaSheet.Cells(criteriaSheet.Rows.Count, 1).End(xlUp).Row
    
    ' Read Find & Replace values from column 1 and column 2
    ReDim replaceText(1 To lastRow), replaceValue(1 To lastRow)

    For i = 1 To lastRow
        replaceText(i) = criteriaSheet.Cells(i, 1).Value
        replaceValue(i) = criteriaSheet.Cells(i, 2).Value
    Next i

    ' Process main document content
    Debug.Print "Processing main document content in: " & filePath
    For i = 1 To lastRow
        With wdDoc.Content.Find
            .Text = replaceText(i)
            .Replacement.Text = replaceValue(i)
            .Forward = True
            .Wrap = 1
            .MatchCase = False
            .MatchWholeWord = False
            .Execute Replace:=2
        End With
    Next i

    ' Process headers **without deleting formatting**
    Debug.Print "Processing headers in: " & filePath
    For Each section In wdDoc.Sections
        For Each header In section.Headers
            If header.Exists Then
                Debug.Print "Replacing in Header: " & header.Range.Text
                For i = 1 To lastRow
                    With header.Range.Find
                        .Text = replaceText(i)
                        .Replacement.Text = replaceValue(i)
                        .Forward = True
                        .Wrap = 1
                        .MatchCase = False
                        .MatchWholeWord = False
                        .Execute Replace:=2
                    End With
                Next i
            End If
        Next header
    Next section

    ' Process footers
    Debug.Print "Processing footers in: " & filePath
    For Each section In wdDoc.Sections
        For Each footer In section.Footers
            If footer.Exists Then
                Debug.Print "Replacing in Footer: " & footer.Range.Text
                For i = 1 To lastRow
                    With footer.Range.Find
                        .Text = replaceText(i)
                        .Replacement.Text = replaceValue(i)
                        .Forward = True
                        .Wrap = 1
                        .MatchCase = False
                        .MatchWholeWord = False
                        .Execute Replace:=2
                    End With
                Next i
            End If
        Next footer
    Next section

    Debug.Print "Finished Find & Replace in: " & filePath
    wdDoc.Save
    wdDoc.Close False
    wdApp.Quit
End Sub