Microsoft Office Forums - View Single Post - [Solved] Adding List Number to Acronym Table

SerenityNetworks · 12-02-2016, 07:26 AM

I've been using Greg and Graham's macro to generate an acronym list. It works great. But I'd like to add a column that provides the list number under which the acronym falls. I'm not a coder and have no idea how to accomplish this task.

Code:

For example, on page 1 we have:
1.     text
1.1    text
       RO Real Options
1.2    text
1.2.1  text
       BOB Big Ol' Bill
1.2.2  Syzygy Goes Wild (SGW)
       text
1.3    text

I would like returned:
RO   1    1.1   RO Real Options
BOB  1  1.2.1   BOB Big Ol' Bill
SGW  1  1.2.2   Syzygy Goes Wild (SGW)

How do I modify the code below to accomplish this? I'm thinking I need another sub to find the list number above or at the current location.

Thank you in advance,
Andrew

Code:

Sub GetAcronymsTEST()
     'A basic Word macro coded by Greg Maxey
     'http://gregmaxey.mvps.org/word_tips.html
     'Modified by Graham Mayor
     'http://www.gmayor.com
    Dim oCol As New Collection
    Dim oColPN As New Collection
    Dim oColLN As New Collection                    'added (for list number)
    Dim oColTxt As New Collection
    Dim oTable As Table
    Dim oCell As Range
    Dim oRng As Word.Range
    Dim oDoc As Word.Document
    Dim lngIndex As Long
    Set oRng = ActiveDocument.Range
    With oRng.Find
        .Text = "<[A-Z]{1,4}>"
        .MatchWildcards = True
        While .Execute
            oCol.Add oRng.Text
            oColTxt.Add oRng.Sentences(1).Text
            oColPN.Add oRng.Information(wdActiveEndPageNumber)
            'call a sub to find previous Paragraphs(1).Range.ListFormat.ListString and put it here
            oRng.Collapse wdCollapseEnd
        Wend
    End With
    Set oDoc = Documents.Add
    Set oTable = oDoc.Tables.Add(oDoc.Range, 1, 4) 'changed 3 to 4
    oTable.Columns(1).Width = CentimetersToPoints(2.5)
    oTable.Columns(2).Width = CentimetersToPoints(1.5)
    oTable.Columns(3).Width = CentimetersToPoints(2.5)  'added
    oTable.Columns(4).Width = CentimetersToPoints(9)
     
    For lngIndex = 1 To oCol.Count
        Set oCell = oTable.Rows.Last.Cells(1).Range
        oCell.End = oCell.End - 1
        oCell.Text = oCol(lngIndex)
        Set oCell = oTable.Rows.Last.Cells(2).Range
        oCell.End = oCell.End - 1
        oCell.Text = oColPN(lngIndex)
        Set oCell = oTable.Rows.Last.Cells(3).Range
        oCell.End = oCell.End - 1
        oCell.Text = oColLN(lngIndex)
        Set oCell = oTable.Rows.Last.Cells(4).Range     'added
        oCell.End = oCell.End - 1                       'added
        oCell.Text = oColTxt(lngIndex)                  'added
        If lngIndex < oCol.Count Then oTable.Rows.Add
    Next lngIndex
     
    oTable.Sort ExcludeHeader:=False, FieldNumber:="Column 1", _
    SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _
    FieldNumber2:="Column 2", SortFieldType2:=wdSortFieldNumeric, SortOrder2 _
    :=wdSortOrderAscending
     
lbl_Exit:
    Set oDoc = Nothing
    Set oRng = Nothing
    Set oTable = Nothing
    Set oCell = Nothing
    Set oCol = Nothing
    Set oColPN = Nothing
    Set oColTxt = Nothing
    Exit Sub
End Sub