Sub BulkFindReplace()
Application.ScreenUpdating = False
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
Dim Rng As Range, Sctn As Section, HdFt As HeaderFooter, strFnd As String, strRep As String
Dim iDataRow As Long, i As Long, xlFList As String, xlRList As String
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\Projects\IMS Structure Change\Find and Replace.xlsx"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
strFolder = GetFolder
If strFolder = "" Then
  MsgBox "No document folder selected", vbExclamation
  Exit Sub
End If
If Dir(strFolder & "\*.docx", vbNormal) = "" Then
  MsgBox "No docx documents in the folder selected", vbExclamation
  Exit Sub
End If
On Error Resume Next
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  ' The file is available, so open it.
  Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMru:=False)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    .Quit
    Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk
    'Ensure the worksheet exists
    If SheetExists(xlWkBk, StrWkSht) = True Then
      With .Worksheets(StrWkSht)
        ' Find the last-used row in column A.
        iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
        ' Capture the F/R data.
        For i = 1 To iDataRow
          ' Skip over empty fields to preserve the underlying cell contents.
          If Trim(.Range("A" & i)) <> vbNullString Then
            xlFList = xlFList & "|" & Trim(.Range("A" & i))
            xlRList = xlRList & "|" & Trim(.Range("B" & i))
          End If
        Next
      End With
    Else
      MsgBox "Cannot find the designated worksheet: " & StrWkSht, vbExclamation
    End If
  .Close False
  End With
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFList = "" Then Exit Sub
'Now we can start processing the documents
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      'Process each word from the F/R List
      For i = 1 To UBound(Split(xlFList, "|"))
        strFnd = Split(xlFList, "|")(i)
        strRep = Split(xlRList, "|")(i)
        Call Update(.Range, strFnd, strRep)
        'Alternatively, to include footnotes, etc."
        'For Each Rng In .StoryRanges
          'Call Update(Rng, strFnd, strRep)
        'Next
        For Each Sctn In .Sections
          For Each HdFt In Sctn.Headers
            Call Update(HdFt.Range, strFnd, strRep)
          Next
          For Each HdFt In Sctn.Footers
            Call Update(HdFt.Range, strFnd, strRep)
          Next
        Next
       Next
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 
Function SheetExists(xlWkBk As Object, SheetName As String) As Boolean
Dim i As Long: SheetExists = False
With xlWkBk
  For i = 1 To .Sheets.Count
    If .Sheets(i).Name = SheetName Then
      SheetExists = True:   Exit For
    End If
  Next
End With
End Function
 
Sub Update(Rng As Range, strFnd As String, strRep As String)
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = strFnd
  .Replacement.Text = strRep
  .Forward = True
  .Wrap = wdFindStop
  .Format = False
  .Execute Replace:=wdReplaceAll
End With
End Sub