<[A-Z]{2,}>
Hit the "More >>" button, then check the "Use Wildcards" box. Finally, click the "Reading Highlight" box, then click "Highlight All".
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