Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, Rng As Range, StrTmp As String, StrFnd As String
Const StrExcl As String = "|,|.|!|:|;|<|>|(|)|{|}|{|}|a|an|the|to|from|with|": j = 100
With ActiveDocument
  For i = 1 To .Range.Words.Count - j
    If InStr(StrExcl, "|" & LCase(Trim(.Words(i))) & "|") = 0 Then
      StrFnd = Replace(Trim(.Words(i)), vbCr, "")
      Set Rng = .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
          Rng.End = .Words.Last.End
          With Rng
            If .Words.Count < j Then
              .Words.First.HighlightColorIndex = wdBrightGreen
              .Words.Last.HighlightColorIndex = wdBrightGreen
            End If
          End With
        End If
      End With
    End If
  Next
End With
Application.ScreenUpdating = True
End Sub