Extract ACRONYMS to New Document

In some documents, you may use many acronyms (i.e. words formed from the initial letters of multi-word names, e.g. VBA for "Visual Basic for Applications"). It is helpful to include the definition/full name the first time you mention an acronym. Alternatively, you may want to create a list of all the acronyms and include the definitions in the list.

Here you will find both a macro and a free Word add-in that lets you extract all the acronyms of a document to a table in a new document. The table has room for the definitions and also shows the page number of the first page where each acronym is used. The acronyms will be sorted alphabetically.

Latest updated 22-Oct-2021. The macro in this article has been changed so it now ignores Content Controls with placeholder text to prevent problems in case of UPPERCASE placeholder text.

Word add-ins ready for use

DocTools ExtractData - a free add-in for Word

Word Add-In from DocTools

DocTools ExtractData is a Word add-in I provide for free. It lets you extract acronyms, bookmarks, tracked changes and comments.

The add-in works with Microsoft Word 2007 and newer versions on PC/Windows.

The add-in lets you easily extract the following types of data from the active document to a new document:

  • acronyms
  • bookmarks
  • tracked changes
  • comments

The extracted data, incl. additional metadata, will be listed in a table for easy overview.

DocTools ExtractData adds a set of tools to a custom tab, DocTools, in the Ribbon. The tools can be accessed from the group Extract Data in the DocTools tab. The DocTools tab may also contain tools from other add-ins provided by DocTools.

The result of extracting acronyms, tracked changes and comments are slightly improved versions of the results you get by using the free macros available on this website. The functionality for extracting bookmarks is available in the add-in only.

How to get the DocTools ExtractData add-in for free

Click the button below to learn more about DocTools ExtractData. You can download the add-in for free.

The functionality for extracting acronyms included in the DocTools ExtractData add-in finds and extracts acronyms consisting of 3 or more letters. It does not extract any definitions.

Macro solution

Read below if you want to use the macro instead of the add-in.

About the comments document that is created

The document with the extracted comments will include a header with the following information:

  • Full name of the document from which the acronyms were extracted
  • Name of the document creator
  • Creation date

The acronyms will be filled into a 3-column table. For each acronym, the table will show:

  • Column 1: The acronym
  • Column 2: Room for inserting the definition/full name
  • Column 3: Page number of first occurrence of the acronym

See the illustration below.

Example of acronyms extracted to a new document

Note that you may need to change the table layout. Among other factors, the result will depend on your default table settings.

The macro

Below, you will find the macro. If you need help on installing the macro, see Related information below.

Sub ExtractACRONYMSToNewDocument()

    'Macro created 2008 by Lene Fredborg, DocTools - www.thedoctools.com
    'Revised 22-Oct-2021 to ignore Content Controls with placeholder text.
    'The macro creates a new document,
    'finds all words consisting of 3 or more uppercase letters
    'in the active document and inserts the words
    'in column 1 of a 3-column table in the new document
    'Each acronym is added only once
    'Use column 2 for definitions
    'Page number of first occurrence is added by the macro in column 3
    'Minor adjustments are made to the styles used
    'You may need to change the style settings and table layout to fit your needs

    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
    Dim Title As String
    Dim Msg As String
    Dim oCC As ContentControl

    Title = "Extract Acronyms to New Document"
    'Show msg - stop if user does not click Yes
    Msg = "This macro finds all words consisting of 3 or more " & _
        "uppercase letters and extracts the words to a table " & _
        "in a new document where you can add definitions." & vbCr & vbCr & _
        "Do you want to continue?"

    If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
        Exit Sub
    End If
    Application.ScreenUpdating = False
    'Find the list separator from international settings
    'May be a comma or semicolon depending on the country
    strListSep = Application.International(wdListSeparator)
    'Start a string to be used for storing names of acronyms found
    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 info in header - change date format as you wish
        .PageSetup.TopMargin = CentimetersToPoints(3)
        .Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
            "Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _
            "Created by: " & Application.UserName & vbCr & _
            "Creation date: " & Format(Date, "MMMM d, yyyy")
        'Adjust the Normal style and Header style
        With .Styles(wdStyleNormal)
            .Font.Name = "Arial"
            .Font.Size = 10
            .ParagraphFormat.LeftIndent = 0
            .ParagraphFormat.SpaceAfter = 6
        End With
        With .Styles(wdStyleHeader)
            .Font.Size = 8
            .ParagraphFormat.SpaceAfter = 0
        End With
        '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
            .Range.Style = wdStyleNormal
            .AllowAutoFit = False
            .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
            'Use wildcard search to find strings consisting of 3 or more uppercase letters
            'Set the search conditions
            'NOTE: If you want to find acronyms with e.g. 2 or more letters,
            'change 3 to 2 in the line below
            .Text = "<[A-Z]{3" & strListSep & "}>"
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = True
            .MatchWildcards = True
            'Perform the search
            Do While .Execute
                'Skip content controls with placeholder text
                If oRange.Information(wdInContentControl) = True Then
                    Set oCC = oRange.ParentContentControl
                    If oCC.ShowingPlaceholderText = True Then
                        oRange.End = oCC.Range.End + 1
                        oRange.Collapse wdCollapseEnd
                        GoTo SkipCC
                    End If
                End If
                'Continue while found
                strAcronym = oRange.Text
                '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
        End With
    End With
    'Sort the acronyms alphabetically - skip if only 1 found
    If n > 2 Then
        With Selection
            .Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
                :=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
            'Go to start of document
            .HomeKey (wdStory)
        End With
    End If
    Application.ScreenUpdating = True
    'If no acronyms found, show msg and close new document without saving
    'Else keep open
    If n = 1 Then
        Msg = "No acronyms found."
        oDoc_Target.Close savechanges:=wdDoNotSaveChanges
        Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document."
    End If
    MsgBox Msg, vbOKOnly, Title
    'Clean up
    Set oRange = Nothing
    Set oDoc_Source = Nothing
    Set oDoc_Target = Nothing
    Set oTable = Nothing
    Set oCC = Nothing
End Sub

Related information

See About VBA Macros and Code Snippets and How to Install a Macro for misc. information that may help you in your work with macros and for information about how to install macros.

For a macro that can extract tracked changes from the active document, see Extract Tracked Changes to New Document.

For a macro that can extract all comments from the active document, see Extract Comments to New Document.