What's wrong with a simple Find/Replace loop, rather than a nested one? Far quicker:
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, arrWords, i As Long
arrWords = Array("keyword1", "keyword2", "keyword3")
Options.DefaultHighlightColorIndex = wdYellow
Set Rng = Selection.Range
With Rng
.Paste
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.Replacement.Text = "^&"
.Replacement.Highlight = True
For i = 0 To UBound(arrWords)
.Text = arrWords(i)
.Execute Replace:=wdReplaceAll
Next
End With
End With
Application.ScreenUpdating = True
End Sub