Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, RngTxt As Range, RngTmp As Range, StrTmp As String, StrFnd As String
Const StrExcl As String = "|,|.|!|:|;|<|>|(|)|{|}|{|}|a|an|the|to|from|with|": j = 25
With ActiveDocument
  For i = 1 To .Range.Words.Count - j
    If InStr(StrExcl, "|" & LCase(Trim(.Words(i))) & "|") = 0 Then
      If .Words(i).InlineShapes.Count = 0 Then
        If .Words(i).Fields.Count = 0 Then
          If Asc(.Words(i).Characters.First) < 128 Then
            StrFnd = Replace(Trim(.Words(i)), vbCr, "")
            Set RngTxt = .Range(.Words(i).Start, .Words(i + j).End)
            With .Range(.Words(i).End, .Words(i + j).End)
              With .Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = StrFnd
                .Replacement.Text = ""
                .Forward = True
                .Wrap = wdFindStop
                .Format = False
                .MatchCase = False
                .MatchWholeWord = True
                .MatchWildcards = False
                .MatchAllWordForms = True
                .Execute
              End With
              If .Find.Found = True Then
                RngTxt.End = .Words.Last.End
                With RngTxt
                  If .Words.Count < j Then
                    Set RngTmp = .Words.First
                    RngTmp.MoveEndWhile " ", -1
                    RngTmp.HighlightColorIndex = wdBrightGreen
                    Set RngTmp = .Words.Last
                    RngTmp.MoveEndWhile " ", -1
                    RngTmp.HighlightColorIndex = wdBrightGreen
                  End If
                End With
              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