Sub AcronymLister()
Application.ScreenUpdating = False
Dim StrTmp As String, StrAcronyms As String, i As Long, j As Long, k As Long, Rng As Range, Tbl As Table
StrAcronyms = "Acronym" & vbTab & "Term" & vbTab & "Page" & vbTab & "Cross-Reference Count" & vbTab & "Cross-Reference Pages" & vbCr
With ActiveDocument
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWildcards = True
      .Wrap = wdFindStop
      .Text = "\([A-Z0-9][A-Z&0-9]{1" & Application.International(wdListSeparator) & "}\)"
      .Replacement.Text = ""
      .Execute
    End With
    Do While .Find.Found = True
      StrTmp = Replace(Replace(.Text, "(", ""), ")", "")
      If (InStr(1, StrAcronyms, .Text, vbBinaryCompare) = 0) And (Not IsNumeric(StrTmp)) Then
        If .Words.First.Previous.Previous.Words(1).Characters.First = Right(StrTmp, 1) Then
          For i = Len(StrTmp) To 1 Step -1
            .MoveStartUntil Mid(StrTmp, i, 1), wdBackward
            .Start = .Start - 1
            If InStr(.Text, vbCr) > 0 Then
              .MoveStartUntil vbCr, wdForward
              .Start = .Start + 1
            End If
            If .Sentences.Count > 1 Then .Start = .Sentences.Last.Start
            If .Characters.Last.Information(wdWithInTable) = False Then
              If .Characters.First.Information(wdWithInTable) = True Then
                .Start = .Cells(.Cells.Count).Range.End + 1
              End If
            ElseIf .Cells.Count > 1 Then
              .Start = .Cells(.Cells.Count).Range.Start
            End If
          Next
        End If
        StrTmp = Replace(Replace(Replace(.Text, " (", "("), "(", "|"), ")", "")
        StrAcronyms = StrAcronyms & Split(StrTmp, "|")(1) & vbTab & Split(StrTmp, "|")(0) & vbTab & .Information(wdActiveEndAdjustedPageNumber) & vbTab & vbTab & vbCr
      End If
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  StrAcronyms = Replace(Replace(Replace(StrAcronyms, " (", "("), "(", vbTab), ")", "")
  Set Rng = ActiveDocument.Range.Characters.Last
  With Rng
    If .Characters.First.Previous <> vbCr Then .InsertAfter vbCr
    .InsertAfter Chr(12)
    .Collapse wdCollapseEnd
    .Style = "Normal"
    .Text = StrAcronyms
    Set Tbl = .ConvertToTable(Separator:=vbTab, NumRows:=.Paragraphs.Count, NumColumns:=5)
    With Tbl
      .Columns.AutoFit
      .Rows(1).HeadingFormat = True
      .Rows(1).Range.Style = "Strong"
      .Rows.Alignment = wdAlignRowCenter
    End With
    .Collapse wdCollapseStart
  End With
  For i = 2 To Tbl.Rows.Count
    StrTmp = "": j = 0: k = 0
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Format = False
        .Forward = True
        .Text = Split(Tbl.Cell(i, 1).Range.Text, vbCr)(0)
        .MatchWildcards = True
        .Execute
      End With
      Do While .Find.Found = True
        If .InRange(Tbl.Range) Then Exit Do
        j = j + 1
        If j > 0 Then
          If k <> .Duplicate.Information(wdActiveEndAdjustedPageNumber) Then
            k = .Duplicate.Information(wdActiveEndAdjustedPageNumber)
            StrTmp = StrTmp & k & " "
          End If
        End If
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
    Tbl.Cell(i, 4).Range.Text = j
    StrTmp = Replace(Trim(StrTmp), " ", ",")
    If StrTmp <> "" Then
      'Add the current record to the output list (StrOut)
      StrTmp = Replace(Replace(ParseNumSeq(StrTmp, "&"), ",", ", "), "  ", " ")
    End If
    Tbl.Cell(i, 5).Range.Text = StrTmp
  Next
End With
Set Rng = Nothing: Set Tbl = Nothing
Application.ScreenUpdating = True
End Sub

Function ParseNumSeq(StrNums As String, Optional StrEnd As String)
'This function converts multiple sequences of 3 or more consecutive numbers in a
' list to a string consisting of the first & last numbers separated by a hyphen.
' The separator for the last sequence can be set via the StrEnd variable.
Dim ArrTmp(), i As Long, j As Long, k As Long
ReDim ArrTmp(UBound(Split(StrNums, ",")))
For i = 0 To UBound(Split(StrNums, ","))
  ArrTmp(i) = Split(StrNums, ",")(i)
Next
For i = 0 To UBound(ArrTmp) - 1
  If IsNumeric(ArrTmp(i)) Then
    k = 2
    For j = i + 2 To UBound(ArrTmp)
      If CInt(ArrTmp(i) + k) <> CInt(ArrTmp(j)) Then Exit For
      ArrTmp(j - 1) = ""
      k = k + 1
    Next
    i = j - 2
  End If
Next
StrNums = Join(ArrTmp, ",")
StrNums = Replace(Replace(Replace(StrNums, ",,", " "), ", ", " "), " ,", " ")
While InStr(StrNums, "  ")
  StrNums = Replace(StrNums, "  ", " ")
Wend
StrNums = Replace(Replace(StrNums, " ", "-"), ",", ", ")
If StrEnd <> "" Then
  i = InStrRev(StrNums, ",")
  If i > 0 Then
    StrNums = Left(StrNums, i - 1) & Replace(StrNums, ",", " " & Trim(StrEnd), i)
  End If
End If
ParseNumSeq = StrNums
End Function

Sub AcronymManager()
Application.ScreenUpdating = False
Dim Rng As Range, Tbl As Table, j As Long, k As Long, r As Long, StrTmp As String, StrExp As String, StrAcc As String
With ActiveDocument
  Set Tbl = .Tables(.Tables.Count)
  For r = 2 To Tbl.Rows.Count
    Set Rng = .Range
    Rng.End = Tbl.Range.Start
    With Rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWholeWord = True
      .MatchCase = True
      .Forward = True
      .Wrap = wdFindStop
      StrAcc = Split(Tbl.Cell(r, 1).Range.Text, vbCr)(0)
      StrExp = Split(Tbl.Cell(r, 2).Range.Text, vbCr)(0)
      .Text = StrExp
      .Replacement.Text = StrAcc
      .Execute Replace:=wdReplaceAll
      .Text = StrAcc & "^w" & "(" & StrAcc & ")"
      .Replacement.Text = StrAcc
      .Execute Replace:=wdReplaceAll
    End With
    With Rng.Find
      .Text = StrAcc
      .Replacement.Text = StrExp & " (" & StrAcc & ")"
      .Execute Replace:=wdReplaceOne
      If .Found = True Then Tbl.Cell(r, 3).Range.Text = Rng.Information(wdActiveEndAdjustedPageNumber)
    End With
  Next
  For r = 2 To Tbl.Rows.Count
    StrTmp = "": j = 0: k = 0
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Format = False
        .Forward = True
        .Text = Split(Tbl.Cell(r, 1).Range.Text, vbCr)(0)
        .MatchWildcards = True
        .Execute
      End With
      Do While .Find.Found = True
        If .InRange(Tbl.Range) Then Exit Do
        With Tbl.Cell(r, 3).Range
          If Split(.Text, vbCr)(0) = "" Then .Text = Rng.Information(wdActiveEndAdjustedPageNumber)
        End With
        j = j + 1
        If j > 0 Then
          If k <> .Duplicate.Information(wdActiveEndAdjustedPageNumber) Then
            k = .Duplicate.Information(wdActiveEndAdjustedPageNumber)
            StrTmp = StrTmp & k & " "
          End If
        End If
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
    Tbl.Cell(r, 4).Range.Text = j
    StrTmp = Replace(Trim(StrTmp), " ", ",")
    If StrTmp <> "" Then
      'Add the current record to the output list (StrOut)
      StrTmp = Replace(Replace(ParseNumSeq(StrTmp, "&"), ",", ", "), "  ", " ")
    End If
    Tbl.Cell(r, 5).Range.Text = StrTmp
  Next
End With
Application.ScreenUpdating = True
End Sub