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