Sub GetKeyWords()
Application.ScreenUpdating = False
Dim Rng1 As Range, Rng2 As Range, StrOut As String, StrExcl As String
StrOut = vbCr
StrExcl = ",A,But,He,Her,I,It,Not,Of,She,The,They,To,We,Who,You,"
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "<[A-Z][A-z0-9]{1,}>"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    Set Rng1 = .Duplicate
    If InStr(StrExcl, "," & Trim(Rng1.Text) & ",") > 0 Then GoTo NextWord
    Rng1.MoveStart wdWord, -1
    On Error Resume Next
    If Not Rng1.Characters.First.Text Like "[.?!]" Then
      Set Rng2 = .Duplicate
      While Rng2.Words.Last.Next.Characters.First.Text Like "[A-Z&]"
        Rng2.MoveEnd wdWord, 1
      Wend
    End If
    If InStr(StrOut, vbCr & Rng2.Text & vbCr) = 0 Then
      StrOut = StrOut & Rng2.Text & vbCr
    End If
NextWord:
    On Error GoTo 0
    .Start = Rng1.End
    If Not Rng2 Is Nothing Then .Start = Rng2.End
    Set Rng2 = Nothing
    .Find.Execute
  Loop
End With
With ActiveDocument
  Set Rng1 = .Range.Characters.Last
  With Rng1
    .InsertAfter vbCr & Chr(12) & StrOut
    .Start = .Start + 2
    .Characters.First.Delete
    .ConvertToTable Separator:=vbTab, Numcolumns:=1
    .Tables(1).Sort Excludeheader:=False, FieldNumber:=1, _
      SortFieldType:=wdSortFieldAlphanumeric, _
      SortOrder:=wdSortOrderAscending, CaseSensitive:=False
  End With
End With
Set Rng1 = Nothing
Application.ScreenUpdating = True
End Sub