Try:
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim RngTxt As Range, RngFnd As Range, RngTmp As Range
Dim StrTmp As String, StrTxt As String
Dim i As Long, j As Long, k As Long
Const StrExcl As String = "|a|an|and|from|in|is|of|the|to|with|": j = 100
With ActiveDocument
For i = 1 To .Range.Words.Count - 1
If InStr(StrExcl, "|" & LCase(Trim(.Words(i))) & "|") = 0 Then
If .Words(i).InlineShapes.Count = 0 Then
If .Words(i).Fields.Count = 0 Then
StrTxt = .Words(i).Characters.First
If ((Asc(StrTxt) > 64) And (Asc(StrTxt) < 91)) Or ((Asc(StrTxt) > 96) And (Asc(StrTxt) < 123)) Then
StrTxt = Replace(Trim(.Words(i)), vbCr, "")
Set RngTxt = .Range(.Words(i).Start, .Range.End)
With RngTxt
If .Words.Count > j Then .MoveEnd Unit:=wdWord, Count:=-(.Words.Count - j)
End With
Set RngFnd = .Range(.Words(i).End, RngTxt.End)
With .Range(.Words(i).End, RngTxt.End)
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = StrTxt
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchAllWordForms = True
.Execute
End With
If .Find.Found = True Then
Set RngTmp = RngTxt.Words.First
RngTmp.MoveEndWhile " ", -1
RngTmp.HighlightColorIndex = wdBrightGreen
Set RngTmp = .Words.Last
RngTmp.MoveEndWhile " ", -1
RngTmp.HighlightColorIndex = wdBrightGreen
End If
End With
End If
Else
i = i + .Words(i).Fields(1).Result.Words.Count - 1
End If
End If
End If
Next
End With
Application.ScreenUpdating = True
End Sub