Adding List Number to Acronym Table

SerenityNetworks · #1 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

gmaxey · #2 12-03-2016, 07:39 AM

Code:

While .Execute
            oCol.Add oRng.Text
            oColTxt.Add oRng.Sentences(1).Text
            oColLN.Add oRng.Paragraphs(1).Range.ListFormat.ListString
            oColPN.Add oRng.Information(wdActiveEndPageNumber)
            oRng.Collapse wdCollapseEnd
        Wend
    End With

SerenityNetworks · #3 12-03-2016, 09:12 AM

Thanks, but this only gets the list number when the acronym is part of the list bullet. I also need it to capture the list number for acronyms that fall under the list.

From your code, it only returns:
SGW 1 1.2.2 Syzygy Goes Wild (SGW)

I need to have 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)

Thanks again,
Andrew

gmaxey · #4 12-03-2016, 11:02 AM

I don't recall my earlier contributions to you macro and there is nothing wrong with Graham's method using collections. However, Graham and I do have different styles and in a case where it doesn't matter if items are repeated I would probably use an array:

Code:

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

SerenityNetworks · #5 12-03-2016, 08:59 PM

Thank you Greg. But the last code you posted hangs. The new document is never created and the script never completes. I've tried to find what loop isn't closed, but the code is beyond my ability to follow.

gmaxey · #6 12-03-2016, 09:26 PM

It worked here with your sample text. However, if the first paragraph was not a list type and contain a AAA, then it would get stuck in a loop. This fixes:

Code:

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
Err_FirstPara:
        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 GoTo Err_FirstPara
          Set oRngLP = oRngLP.Paragraphs(1).Previous.Range
        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
      On Error GoTo 0
      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

SerenityNetworks · #7 12-13-2016, 01:36 PM

Thank you. Please pardon my delay in responding. No excuses; I just got overly busy. I certainly appreciate your work.

The revised macro still throws a runtime error #91, object variable or with block variable not set error when there is more than one line containing an acronym that comes before the first list. For example, in your demo document, add a second line that says, "New line BBB." When the macro is run it errors out at, "Set oRngLP = oRngLP.Paragraphs(1).Previous.Range". My workaround is just to make the first line a list and change it back after the macro runs, but I thought I'd let you know in case others are following this thread.

Then a couple of last thoughts/requests, which are by no means important but would make the macro pretty slick. (1) Sometimes I want listed the appearance of every acronym regardless of how many times it appears. Sometimes (most often) I only want to output the first appearance of an acronym. I wonder if there is an easy way to add code that would restrict the output to only the first instance of the acronym and then comment out the code if I want to output every instance. If it's not easy to do then I can just sort and delete the extras, which is what I have been doing. (2) In using your macro I noted that where I have a sentence or paragraph where every character is in uppercase then all the words 'n' characters in length will be output as acronyms. So I replaced the .text code you had with: .Text = "\([A-Z]{2,}\)" This allows me to only capture acronyms contained within parenthesis. Do you see any issue with this modification?

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
adding tables based on a number given in a form	coba	Word VBA	5	12-26-2015 07:05 PM
Acronym Finder	Cray_Z	Word VBA	14	09-22-2014 11:42 PM
How to create a table with a number of line depending a number entered by user	Cellendhyll	Word Tables	3	07-10-2014 05:49 AM
List Style Numbering picks up out of order number from LATER list	spthomas	Word	12	12-16-2013 05:23 PM
Adding Characters to Page Number	Daved2424	Word	6	01-22-2011 07:11 PM