Below you will find a macro that extracts all words consisting of three or
more uppercase letters to a new document. I have added comments in the code
that explains what is going on. You may want to add more code to adjust the
layout of the table into which the acronyms are inserted. I just made the
macro and tested it on a small test document and it seems to work correctly –
however, you may want to adjust what it does.
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
--
Regards
Lene Fredborg - Microsoft MVP (Word)
DocTools - Denmark
www.thedoctools.com
Document automation - add-ins, macros and templates for Microsoft Word
BHW said:
Hi,
Back in '02 Mark Tangard suggested this snippet to find macros.
With Selection.Find
.Text = "<[A-Z]{3,}>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
.Execute
End With
Has anyone (or would anyone like to) used this to create a fuller
macro that reads through file 1, finds acronyms, and writes them and
the page number to file 2? Alternatively, has anyone written a macro
that finds the first use of an acronym and somehow checks that it is
indeed defined (and only defined once!) with that first use?
Cheers, Bruce
