Dear Macropod,
Dear all,
I updated the code based on the ones within the links provided. It is now working on the assumption of a document containing two tables: the table containing the acronym with its definition and the table with acronym to find and list with their definition at the end of the document.
I would like to avoid finding duplicates and having to type the known acronym definition located in the second column of table 1. Is there a way to do this?
Code:
Sub ACRO_table3()
Dim oTbl As Table, qTbl As Table
Dim oRng As Range
Dim strAcr As String, strFnd As String, strDef As String
Dim i As Long, j As Long
strAcr = ","
Set oTbl = ActiveDocument.Tables(1) 'the 2-column table containing the acronym and definition
Set qTbl = ActiveDocument.Tables(2) 'the table containing the acronyms to list with their definition
Set oRng = ActiveDocument.Range.Characters.Last
For i = 1 To oTbl.Rows.Count
With oTbl.Cell(i, 1).Range
strFnd = Left(.Text, Len(.Text) - 2)
strAcr = strAcr & strFnd & ","
End With
Next i
With qTbl.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Text = "<[A-Z]{3,}>"
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
strFnd = .Text
If .Characters.Last.Information(wdWithInTable) = True Then
If InStr(strAcr, "," & strFnd & ",") <> 0 Then
strAcr = strAcr & strFnd & ","
strDef = Trim(InputBox("KNOWN Term Found: " & strFnd & vbCr & _
"Add to definitions?" & vbCr & _
"If yes, type the definition."))
If strDef <> vbNullString Then
With oRng
.Text = strFnd & " = " & strDef & "; "
.Collapse wdCollapseEnd
.Style = "Legend"
.InsertParagraph
End With
End If
ElseIf 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 oRng
.Text = strFnd & " = " & strDef & ";" & vbNewLine
.Collapse wdCollapseEnd
.Style = "Legend"
.HighlightColorIndex = wdYellow
.InsertParagraph
End With
End If
Else
End If
Else: Exit Do
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End Sub