Extract Acronyms to a new document

A newsgroup contributor asked if it was possible to extract acronyms to a new document. The following will extract all words in the format NATO or N.A.T.O. consisting of more than two characters to a new document. The list is then sorted and duplicate entries removed. The macro does not extract acronyms that are adopted as proper nouns e.g. Unesco.

Sub ExtractAcronyms() Dim rText As Range Dim SDoc As Document Dim TDoc As Document Set SDoc = ActiveDocument Set TDoc = Documents.Add SDoc.Activate With Selection     .HomeKey wdStory     With .Find         .ClearFormatting         .Replacement.ClearFormatting         .Replacement.Text = ""         Do While .Execute(findText:="[A-Z.]{2,}", _             MatchWildcards:=True, _             Wrap:=wdFindStop, Forward:=True) = True             Set rText = Selection.Range             TDoc.Range.InsertAfter rText & vbCr             rText.Collapse wdCollapseEnd         Loop     End With End With With TDoc      .Range.Sort ExcludeHeader:=False, _         FieldNumber:="Paragraphs", _         SortFieldType:=wdSortFieldAlphanumeric, _         SortOrder:=wdSortOrderAscending      .Paragraphs(1).Range.Delete      .Activate End With End Sub