Sub BulkFindReplaceWithParameters()
Application.ScreenUpdating = True
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean, i As Long
Dim xlFExpr, xlRExpr, xlFWild, xlFFrmt, xlFBold, xlFItal, xlFUnln, xlFPnts, xlRBold, xlRItal, xlRUnln, xlRPnts
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\BulkFindReplace.xls"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
' Test whether Excel is already running.
On Error Resume Next
bStrt = False ' Flag to record if we start Excel, so we can close it later.
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
  Set xlApp = CreateObject("Excel.Application")
  If xlApp Is Nothing Then
    MsgBox "Can't start Excel.", vbExclamation
    Exit Sub
  End If
  ' Record that we've started Excel.
  bStrt = True
End If
On Error GoTo 0
'Check if the workbook is open.
bFound = False
With xlApp
  'Hide our Excel session
  If bStrt = True Then .Visible = False
  For Each xlWkBk In .Workbooks
    If xlWkBk.FullName = StrWkBkNm Then ' It's open
      Set xlWkBk = xlWkBk
      bFound = True
      Exit For
    End If
  Next
  ' If not open by the current user.
  If bFound = False Then
    ' Check if another user has it open.
    If IsFileLocked(StrWkBkNm) = True Then
      ' Report and exit if true
      MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use"
      If bStrt = True Then .Quit
      Exit Sub
    End If
    ' The file is available, so open it.
    Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm)
    If xlWkBk Is Nothing Then
      MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
      If bStrt = True Then .Quit
      Exit Sub
    End If
  End If
  ' Process the workbook.
  With xlWkBk
      With .Worksheets(StrWkShtNm)
      ' Find the last-used row in column A.
      ' Add 1 to get the next row for data-entry.
      iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
      ' Get the Find/Replace parameters.
      For i = 2 To iDataRow
        ' Skip over empty fields to preserve the underlying cell contents.
        If Trim(.Range("A" & i)) <> vbNullString Then
          xlFExpr = xlFExpr & "|" & Trim(.Range("A" & i))
          xlRExpr = xlRExpr & "|" & Trim(.Range("B" & i))
          xlFWild = xlFWild & "|" & Trim(.Range("C" & i))
          xlFFrmt = xlFFrmt & "|" & Trim(.Range("D" & i))
          xlFBold = xlFBold & "|" & Trim(.Range("E" & i))
          xlFItal = xlFItal & "|" & Trim(.Range("F" & i))
          xlFUnln = xlFUnln & "|" & Trim(.Range("G" & i))
          xlFPnts = xlFPnts & "|" & Trim(.Range("H" & i))
          xlRBold = xlRBold & "|" & Trim(.Range("I" & i))
          xlRItal = xlRItal & "|" & Trim(.Range("J" & i))
          xlRUnln = xlRUnln & "|" & Trim(.Range("K" & i))
          xlRPnts = xlRPnts & "|" & Trim(.Range("L" & i))
        End If
      Next
    End With
    If bFound = False Then xlWkBk.Close False
    If bStrt = True Then .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Process each word from the F/R List
For i = 1 To UBound(Split(xlFExpr, "|"))
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = CBool(Split(xlFFrmt, "|")(i))
      .MatchWildcards = False
      .MatchWholeWord = True
      .MatchCase = True
      If CBool(Split(xlFWild, "|")(i)) = True Then
        .MatchWildcards = True
        .MatchWholeWord = False
        .MatchCase = False
      End If
      With .Font
        If Split(xlFBold, "|")(i) <> "" Then .Bold = CBool(Split(xlFBold, "|")(i))
        If Split(xlFItal, "|")(i) <> "" Then .Italic = CBool(Split(xlFItal, "|")(i))
        If Split(xlFUnln, "|")(i) <> "" Then .Underline = CBool(Split(xlFUnln, "|")(i))
        If Split(xlFPnts, "|")(i) <> "" Then .Size = Split(xlFPnts, "|")(i)
      End With
      With .Replacement.Font
        If Split(xlRBold, "|")(i) <> "" Then .Bold = CBool(Split(xlRBold, "|")(i))
        If Split(xlRItal, "|")(i) <> "" Then .Italic = CBool(Split(xlRItal, "|")(i))
        If Split(xlRUnln, "|")(i) <> "" Then .Underline = CBool(Split(xlRUnln, "|")(i))
        If Split(xlRPnts, "|")(i) <> "" Then .Size = Split(xlRPnts, "|")(i)
      End With
      .Wrap = wdFindContinue
      .Text = Split(xlFExpr, "|")(i)
      .Replacement.Text = Split(xlRExpr, "|")(i)
      .Execute Replace:=wdReplaceAll
    End With
  End With
Next
ErrExit:
Application.ScreenUpdating = True
End Sub
 
Function IsFileLocked(strFileName As String) As Boolean
  On Error Resume Next
  Open strFileName For Binary Access Read Write Lock Read Write As #1
  Close #1
  IsFileLocked = Err.Number
  Err.Clear
End Function