Results 1 to 8 of 8
  1. #1
    New Lounger
    Join Date
    Jun 2009
    Posts
    4
    Thanks
    0
    Thanked 0 Times in 0 Posts
    I love this acronym finder macro.

    - Searches through a Word document,
    - Collects all 3 or more letter acronyms and associated page numbers,
    - Creates a new document with 3 columns: Acronym, Definition (manual data input) and Page number, and
    - Pastes in the data.

    Just one wish (and I realize this is a tall order);
    - When an acronym is found, collect the associated definition.
    In our typical documents, the definition is always stated/available at the first occurrence in front of the acronym. For example ?Commercial Off the Shelf (COTS)?. Is it possible that when an acronym is identified in parenthesis (indicating first occurrence) the macro will copy associated definition to the ?Definition? column in the new ?Acronyms? document?

    The macro:

    [codebox]Sub ExtractAcronymsToNewDocument()
    'Finds all words consisting of 3 or more uppercase letters
    'in active document document and inserts the words
    'in column 1 of a 3-column table in a new document
    'Each acronym is added only once
    'Room for definition in column 2
    'Page number of first occurrence is added in column 3
    Dim oDoc_Source As Document
    Dim oDoc_Target As Document
    Dim strListSep As String
    Dim strAcronym As String
    Dim oTable As Table
    Dim oRange As Range
    Dim n As Long
    Dim strAllFound As String 'use to keep track of foudnd
    'Find the list separator from international settings
    'In some countries it is comma, in other semicolon
    strListSep = Application.International(wdListSeparator)
    strAllFound = "#"
    Set oDoc_Source = ActiveDocument
    'Create new document for acronyms
    Set oDoc_Target = Documents.Add
    With oDoc_Target
    'Make sure document is empty
    .Range = ""
    'Insert a table with room for acronym and definition
    Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
    With oTable
    'Format the table a bit
    'Insert headings
    .Cell(1, 1).Range.Text = "Acronym"
    .Cell(1, 2).Range.Text = "Definition"
    .Cell(1, 3).Range.Text = "Page"
    'Set row as heading row
    .Rows(1).HeadingFormat = True
    .Rows(1).Range.Font.Bold = True
    .PreferredWidthType = wdPreferredWidthPercent
    .Columns(1).PreferredWidth = 20
    .Columns(2).PreferredWidth = 70
    .Columns(3).PreferredWidth = 10
    End With
    End With
    With oDoc_Source
    Set oRange = .Range
    n = 1 'used to count below
    With oRange.Find
    .Text = "<[A-Z]{3" & strListSep & "}>"
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = True
    .MatchWildcards = True
    Do While .Execute
    'Continue while found
    strAcronym = oRange
    'Insert in target doc
    'If strAcronym is already in strAllFound, do not add again
    If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
    'Add new row in table from second acronym
    If n > 1 Then oTable.Rows.Add
    'Was not found before
    strAllFound = strAllFound & strAcronym & "#"
    'Insert in column 1 in oTable
    'Compensate for heading row
    With oTable
    .Cell(n + 1, 1).Range.Text = strAcronym
    'Insert page number in column 3
    .Cell(n + 1, 3).Range.Text oRange.Information(wdActiveEndPageNumber)
    End With
    n = n + 1
    End If
    'If acronym
    Loop
    End With
    End With
    'Sort the acronyms alphabetically
    With Selection
    .Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
    :=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
    .HomeKey (wdStory)
    End With
    'Clean up
    Set oDoc_Source = Nothing
    Set oDoc_Target = Nothing
    Set oTable = Nothing
    MsgBox "Finished extracting " & n - 1 & " acronymn(s) to a new document."
    End Sub[/codebox]

    I received the following solution from another group but get a "Value out of Range" error at the first "While InStr(... line.

    [codebox]Function GetAcronymDefinition(aRange As Range) As String
    Dim charPointer As Long
    Dim wordCounter As Integer

    charPointer = aRange.Start
    wordCounter = Len(aRange.Text)
    While wordCounter > 0
    While InStr(" .,;:""/?_=+[]{}\|!@#$%^&*()", aRange.Document.Range(charPointer - 1, charPointer)) > 0
    If charPointer <= 1 Then
    Exit Function
    End If
    charPointer = charPointer - 1
    Wend
    While InStr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQ RSTUVWXYZ0123456789", _
    aRange.Document.Range(charPointer - 1, charPointer)) > 0
    If charPointer <= 1 Then
    Exit Function
    End If
    charPointer = charPointer - 1
    Wend
    wordCounter = wordCounter - 1
    Wend
    GetAcronymDefinition = Trim(aRange.Document.Range(charPointer, aRange.Start - 1))
    End Function[/codebox]
    If anyone knows how to alter this code to show me that first occurrence definition in the newly created 'acronym" sheet, I would be forever grateful!!

    Ian

  2. #2
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts
    Welcome to the Lounge!

    Add the following declaration to the others at the beginning of ExtractAcronymsToNewDocument:

    Dim strDef As String

    Between the lines

    .Cell(n + 1, 1).Range.Text = strAcronym

    and

    .Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)

    insert a new line

    .Cell(n + 1, 2).Range.Text = GetAcronymDefinition(oRange)

    Note: this will work correctly if the definitions consist of letters and digits (and spaces) only. Other characters are interpreted as word delimiters.
    For example, if your document contains

    ?Woody's Lounge (WL)?

    the code will list the definition as

    s Lounge

    because the apostrophe is seen as a word delimiter.

  3. #3
    New Lounger
    Join Date
    Jun 2009
    Posts
    4
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Thank you Hans for your quick reply.

    Word is still complaining about (value out of range) that line in the Function:

    While InStr(" .,;:""/?_=+[]{}\|!@#$%^&*()", aRange.Document.Range(charPointer - 1, charPointer)) > 0

    If you've got some more time, would you have another look?

    Thank you again Hans. I'll provide the code as modified with your suggestion:
    [codebox]
    Sub ExtractAcronymsToNewDocument()

    Dim oDoc_Source As Document
    Dim oDoc_Target As Document
    Dim strListSep As String
    Dim strAcronym As String
    Dim oTable As Table
    Dim oRange As Range
    Dim n As Long
    Dim strDef As String
    Dim strAllFound As String

    strListSep = Application.International(wdListSeparator)

    strAllFound = "#"

    Set oDoc_Source = ActiveDocument
    Set oDoc_Target = Documents.Add

    With oDoc_Target
    .Range = ""

    Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
    With oTable
    .Cell(1, 1).Range.Text = "Acronym"
    .Cell(1, 2).Range.Text = "Definition"
    .Cell(1, 3).Range.Text = "Page"
    .Rows(1).HeadingFormat = True
    .Rows(1).Range.Font.Bold = True
    .PreferredWidthType = wdPreferredWidthPercent
    .Columns(1).PreferredWidth = 20
    .Columns(2).PreferredWidth = 70
    .Columns(3).PreferredWidth = 10
    End With
    End With

    With oDoc_Source
    Set oRange = .Range

    n = 1

    With oRange.Find
    .Text = "<[A-Z]{3" & strListSep & "}>"
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = True
    .MatchWildcards = True
    Do While .Execute
    strAcronym = oRange

    If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
    If n > 1 Then oTable.Rows.Add
    strAllFound = strAllFound & strAcronym & "#"

    With oTable
    .Cell(n + 1, 1).Range.Text = strAcronym
    .Cell(n + 1, 2).Range.Text = GetAcronymDefinition(oRange)
    .Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)
    End With

    n = n + 1
    End If

    Loop
    End With
    End With

    With Selection
    .Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
    :=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending

    .HomeKey (wdStory)
    End With

    Set oDoc_Source = Nothing
    Set oDoc_Target = Nothing
    Set oTable = Nothing

    MsgBox "Finished extracting " & n - 1 & " acronymn(s) to a new document."

    End Sub
    -------------------------------------------------------------------------------------------------------
    Function GetAcronymDefinition(aRange As Range) As String
    Dim charPointer As Long
    Dim wordCounter As Integer

    charPointer = aRange.Start
    wordCounter = Len(aRange.Text)
    While wordCounter > 0
    While InStr(" .,;:""/?_=+[]{}\|!@#$%^&*()", aRange.Document.Range(charPointer - 1, charPointer)) > 0
    If charPointer <= 1 Then
    Exit Function
    End If
    charPointer = charPointer - 1
    Wend
    While InStr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQ RSTUVWXYZ0123456789", _
    aRange.Document.Range(charPointer - 1, charPointer)) > 0
    If charPointer <= 1 Then
    Exit Function
    End If
    charPointer = charPointer - 1
    Wend
    wordCounter = wordCounter - 1
    Wend
    GetAcronymDefinition = Trim(aRange.Document.Range(charPointer, aRange.Start - 1))
    End Function
    [/codebox]

  4. #4
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts
    I tested the code and it worked correctly, so I'll have to see a sample document where it fails. Could you attach such a document to a reply? Remove or alter sensitive information.

  5. #5
    New Lounger
    Join Date
    Jun 2009
    Posts
    4
    Thanks
    0
    Thanked 0 Times in 0 Posts
    I've prepared and uploaded a document we can use as a baseline for discussion.
    All seems to work fine after all. Thank you.
    Just a couple of observations:
    - The macro locks up when it encounters a acronym at the beginning of a paragraph or is out by itself.
    - If the definition has dashes, it won't be interperated correctly,
    Is it possible to have numbers as part of the acronym...

    Ian
    Attached Files Attached Files

  6. #6
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts
    You told us that the first occurrence of each acronym, i.e. 2 or more upper case letters would be preceded by the definition.
    So you should avoid the use of words in upper case if they're not acronyms. Write "End" instead of "END" for example.

    You could allow digits in acronyms, e.g.

    To be or not to be (2BR02B)
    Day to day (D2D)

    by using

    With oRange.Find
    .Text = "<[A-Z0-9]{2" & strListSep & "}>"
    ...

    but as a consequence, a year such as 1493 would be considered an acronym too.

  7. #7
    New Lounger
    Join Date
    Jun 2009
    Posts
    4
    Thanks
    0
    Thanked 0 Times in 0 Posts
    The first occurence always has the definition but, that dosen't mean the acronym won't be used elsewear in the document. The maco is perfect and I'd like to thank you again for your help.

    I've got another macro issue...

    As a close out procedure after editting, the document must be free of comments, track changes and macros.
    I've got 3 seperate macros that each take care of these requirements seperatley. What is the best way to string them together so I have a single macro/button solution?

    1. Remove all comments:

    [codebox]Sub DeleteAllCommentsAndConfirm()
    Dim i As Integer
    If MsgBox("Are you sure you want to delete ALL comments in this document?",vbYesNo) = vbYes Then
    iNumberOfComments - ActiveDocument.Comments.count
    For i = iNumberOfComments To 1 Step -1
    ActiveDocument.comments(i).Delete
    Next i
    MsgBox iNumberOfComments & "Comment(s) Deleted", vbInformation
    End If
    End Sub[/codebox]

    2. Remove all Track Changes:

    [codebox]Sub TC()
    Dim oRev As Revision
    Dim oCom As Comment
    Dim i As Long
    For Each oRev In ActiveDocument.Revisions
    oRev.Accept
    Next oRev
    For i = ActiveDocument.Comments.Count To 1 Step -1
    ActiveDocument.Comments(i).Delete
    Next i

    End Sub[/codebox]

    3. Remove all macros (this one does not work properly)

    [codebox]Sub RemoveAllMacros(objDocument As Object)
    Dim i As Long, l As Long
    If objDocument Is Nothing Then Exit Sub
    i = 0
    On Error Resume Next
    i = objDocument.VBProject.VBComponents.Count
    On Error GoTo 0
    If i < 1 Then ' no VBComponents or protected VBProject
    MsgBox "The VBProject in " & objDocument.Name & _
    " is protected or has no components!", _
    vbInformation, "Remove All Macros"
    Exit Sub
    End If
    With objDocument.VBProject
    For i = .VBComponents.Count To 1 Step -1
    On Error Resume Next
    .VBComponents.Remove .VBComponents(i)
    ' delete the component
    On Error GoTo 0
    Next i
    End With
    With objDocument.VBProject
    For i = .VBComponents.Count To 1 Step -1
    l = 1
    On Error Resume Next
    l = .VBComponents(i).CodeModule.CountOfLines
    .VBComponents(i).CodeModule.DeleteLines 1, l
    ' clear lines
    On Error GoTo 0
    Next i
    End With
    End Sub[/codebox]

    Stop me if you think I'm taking advantage of your generosity.

    Thanks Hans,

    Ian

  8. #8
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts
    Instead of

    For Each oRev In ActiveDocument.Revisions
    oRev.Accept
    Next oRev

    you could use the single line

    ActiveDocument.Revisions.AcceptAll

    You can create a macro that will call several other macros in succession, e.g.

    Code:
    Sub RemoveCommentsAndRevisions
      Call DeleteAllCommentsAndConfirm
      Call TC
    End Sub
    I would recommend not to use a macro to remove VBA code. This is rather tricky, in my experience, and it requires that users allow programmatic access to the VBA project, which makes it vulnerable.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •