Apart from anything else, the code you're using is extremely inefficient. Try:
Code:
Sub BulkFindReplace()
Application.ScreenUpdating = False
Dim FRDoc As Document, FRList, i As Long
'Load the strings from the reference doc into a text string to be used as an array.
Set FRDoc = Documents.Open("Drive:\FilePath\FindReplaceList.doc", ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
FRList = FRDoc.Range.Text: FRDoc.Close False: Set FRDoc = Nothing
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Color = wdColorRed
.Replacement.Text = "^&"
.Forward = True
.Format = True
.MatchWholeWord = True
'Process each entry from the source list.
For i = 0 To UBound(Split(FRList, vbCr)) - 1
.Text = Split(FRList, vbCr)(i)
.Execute Replace:=wdReplaceAll
Next
End With
Application.ScreenUpdating = True
End Sub
The above code assumes the strings to be found are separated by paragraph breaks. This allows you to process multi-word strings. If you're using spaces instead, use:
Code:
Sub BulkFindReplace()
Application.ScreenUpdating = False
Dim FRDoc As Document, FRList, i As Long
'Load the strings from the reference doc into a text string to be used as an array.
Set FRDoc = Documents.Open("Drive:\FilePath\FindReplaceList.doc", ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
FRList = FRDoc.Range.Text: FRDoc.Close False: Set FRDoc = Nothing
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Color = wdColorRed
.Replacement.Text = "^&"
.Forward = True
.Format = True
.MatchWholeWord = True
'Process each entry from the source list.
For i = 0 To UBound(Split(FRList, " "))
.Text = Split(FRList, " ")(i)
.Execute Replace:=wdReplaceAll
Next
End With
Application.ScreenUpdating = True
End Sub