Sub CheckWords()
Application.ScreenUpdating = False
Dim strWords As String, i As Long
strWords = strWords & "a,am,an,are,been,began,brought,can,check,come,"
strWords = strWords & "do,find,found,get,give,go,have,hear,let,lot,"
strWords = strWords & "make,may,me,might,number,numeral,oh,plain,plane,"
strWords = strWords & "pose,pound,query,quiet,quite,ran,run,say,see,"
strWords = strWords & "should,song,spell,state,stood,those,take,would"
With ActiveDocumentRange.Find
.ClearFormatting
.Forward = True
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Wrap = wdFindContinue
With .Replacement
.ClearFormatting
.Text = "^&"
.Font.Color = wdColorRed
End With
For i = 0 To UBound(Split(strWords, ","))
.Text = Split(strWords, ",")(i)
.Execute Replace:=wdReplaceAll
Next i
End With
Application.ScreenUpdating = True
End Sub