Sub GetAcronyms()
'A basic Word macro coded by Greg Maxey http://gregmaxey.com/word_tips.html
Dim oTbl As Table
Dim oRng As Word.Range, oRngLP As Range
Dim oDoc As Word.Document
Dim lngIndex As Long, lngVal As Long
Dim arrVals() As String
  ReDim arrVals(3, 0)
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Text = "<[A-Z]{1,4}>"
    .MatchWildcards = True
    While .Execute
      arrVals(0, UBound(arrVals, 2)) = oRng.Text
      arrVals(3, UBound(arrVals, 2)) = oRng.Sentences(1).Text
      If Not oRng.Paragraphs(1).Range.ListFormat.ListString = vbNullString Then
        arrVals(1, UBound(arrVals, 2)) = oRng.Information(wdActiveEndPageNumber)
        arrVals(2, UBound(arrVals, 2)) = oRng.Paragraphs(1).Range.ListFormat.ListString
      Else
        Set oRngLP = oRng.Duplicate
        Do
          On Error Resume Next
          Set oRngLP = oRngLP.Paragraphs(1).Previous.Range
          On Error GoTo 0
        Loop Until oRngLP.Paragraphs(1).Range.ListFormat.ListString <> vbNullString
        arrVals(1, UBound(arrVals, 2)) = oRngLP.Information(wdActiveEndPageNumber)
        arrVals(2, UBound(arrVals, 2)) = oRngLP.Paragraphs(1).Range.ListFormat.ListString
      End If
      ReDim Preserve arrVals(3, UBound(arrVals, 2) + 1)
      oRng.Collapse wdCollapseEnd
    Wend
  End With
  ReDim Preserve arrVals(3, UBound(arrVals, 2) - 1)
  Set oDoc = Documents.Add
  Set oTbl = oDoc.Tables.Add(oDoc.Range, 1, 4)
  With oTbl
    .Columns(1).Width = CentimetersToPoints(2.5)
    .Columns(2).Width = CentimetersToPoints(1.5)
    .Columns(3).Width = CentimetersToPoints(2.5)
    .Columns(4).Width = CentimetersToPoints(9)
  End With
  For lngIndex = 0 To UBound(arrVals, 2)
    For lngVal = 0 To 3
      oTbl.Rows.Last.Cells(lngVal + 1).Range.Text = arrVals(lngVal, lngIndex)
    Next lngVal
    If lngIndex < UBound(arrVals, 2) Then oTbl.Rows.Add
  Next lngIndex
  'oTbl.Sort ExcludeHeader:=False, FieldNumber:="Column 1", _
  SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _
  FieldNumber2:="Column 3", SortFieldType2:=wdSortFieldNumeric, SortOrder2 _
  :=wdSortOrderAscending
lbl_Exit:
  Set oDoc = Nothing: Set oTbl = Nothing
End Sub