How to create a list of acronyms in Microsoft Word with Macro?

Sub ListAcronyms()
    Dim strAcronym As String
    Dim strDefine As String
    Dim strOutput As String
    Dim newDoc As Document

    Application.ScreenUpdating = False
    Selection.HomeKey Unit:=wdStory
    ActiveWindow.View.ShowHiddenText = False

   'Loop to find all acronyms
    Do
        'Search for acronyms using wildcards
        Selection.Find.ClearFormatting
        With Selection.Find
            .ClearFormatting
            .Text = "<[A-Z]@[A-Z]>"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = True
            .MatchWildcards = True
            .MatchWholeWord = True
            .Execute
        End With

        'Only process if something found
        If Selection.Find.Found Then
            'Make a string from the selection, add it to the
            'output string
            strAcronym = Selection.Text

            'Look for definition
            Selection.MoveRight Unit:=wdWord
            Selection.MoveRight Unit:=wdCharacter, _
              Extend:=wdExtend
            strDefine = ""
            If Selection.Text = "(" Then
                While Selection <> ")"
                    strDefine = strDefine & Selection.Text
                    Selection.Collapse Direction:=wdCollapseEnd
                    Selection.MoveRight Unit:=wdCharacter, _
                      Extend:=wdExtend
                Wend
            End If
            Selection.Collapse Direction:=wdCollapseEnd
            If Left(strDefine, 1) = "(" Then
                strDefine = Mid(strDefine, 2, Len(strDefine))
            End If
            If strDefine > "" Then
                'Check if the search result is in the Output string
                'if it is, ignore the search result
                If InStr(strOutput, strAcronym) = 0 Then
                    strOutput = strOutput & strAcronym _
                      & vbTab & strDefine & vbCr
                End If
            End If
        End If
    Loop Until Not Selection.Find.Found

    'Create new document and change active document
    Set newDoc = Documents.Add

    'Insert the text
    Selection.TypeText Text:=strOutput

    'Sort it
    newDoc.Content.Sort SortOrder:=wdSortOrderAscending
    Application.ScreenUpdating = True
    Selection.HomeKey Unit:=wdStory
End Sub