The macro below checks the contents of a document against a series of expressions in the second column of the first table in the document, and outputs a count of those matches in the third column of the table. Document contents before the table are not checked (this makes it more flexible for use in a document where you want to exclude the ‘front matter’ from checking). For your purposes, the acronyms would be stored in the second column. Only minor modifications would be needed to adapt this to use the 1st & 2nd columns instead of the 2nd & 3rd columns. Using the 2nd & 3rd columns, though, allows you to put the acronym's description in the 1st column.
Code:
Sub AcronymFinder()
Application.ScreenUpdating = False
Dim RngDoc As Range, oTbl As Table, i As Long, j As Long
Dim strAcr As String, strFnd As String, strDef As String
strAcr = ","
Set RngDoc = ActiveDocument.Range
With ActiveDocument
Set oTbl = .Tables(1)
RngDoc.Start = oTbl.Range.End
For i = 2 To oTbl.Rows.Count
With oTbl.Cell(i, 2).Range
strFnd = Left(.Text, Len(.Text) - 2)
strAcr = strAcr & strFnd & ","
End With
Next
With RngDoc
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Text = "\([A-Z][A-Za-z0-9]@\)"
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
.Start = .Start + 1
.End = .End - 1
strFnd = .Text
If InStr(strAcr, "," & strFnd & ",") = 0 Then
strAcr = strAcr & strFnd & ","
strDef = Trim(InputBox("New Term Found: " & strFnd & vbCr & _
"Add to definitions?" & vbCr & _
"If yes, type the definition."))
If strDef <> vbNullString Then
With oTbl.Rows
.Add
.Last.Cells(1).Range.Text = strDef
.Last.Cells(2).Range.Text = strFnd
End With
End If
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
For i = oTbl.Rows.Count To 2 Step -1
With oTbl.Cell(i, 2).Range
strFnd = Left(.Text, Len(.Text) - 2)
End With
Set RngDoc = ActiveDocument.Range
With RngDoc
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Text = strFnd
.MatchWholeWord = True
.MatchWildcards = False
.MatchCase = True
.Execute
End With
j = 0
Do While .Find.Found
j = j + 1
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
If j < 2 Then
oTbl.Rows(i).Delete
Else
oTbl.Cell(i, 3).Range.Text = j - 1
End If
Next
End With
Set RngDoc = Nothing: Set oTbl = Nothing
Application.ScreenUpdating = True
End Sub
Note: Although you defined an acronym as "An acronym in this case consists of
AT LEAST two capital letters", the code tests any parenthetic single-word alpha-numeric string beginning with a capital letter; it's up to you to decide whether to add that string to the acronym list or skip it. The enhanced code also assumes the table has a header row.
01-22-2014, 03:22 PM
Similar Threads
Macro for microsoft Word
Windows 7 32bit 
Office 2010 32bit
Hybrid Mode