Sub CreateAcronymAppendixDocument()
Application.ScreenUpdating = False
Dim DocAcro As Document, DocSrc As Document, DocTgt As Document
Dim oTbl As Table, i As Long, j As Long
Dim strAcr As String, strFnd As String, strDef As String
strAcr = ","
Set DocAcro = ThisDocument
With Dialogs(wdDialogFileOpen)
  If .Show = False Then Exit Sub
End With
Set DocSrc = ActiveDocument
Set DocTgt = Documents.Add(DocSrc.AttachedTemplate.FullName)
DocTgt.Range.FormattedText = DocAcro.Range.FormattedText
With DocTgt
  Set oTbl = .Tables(1)
  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
End With
With DocSrc.Range
  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
  With DocSrc.Range
    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 = 0 Then
    oTbl.Rows(i).Delete
  Else
    oTbl.Cell(i, 3).Range.Text = j
  End If
Next
Set oTbl = Nothing: Set DocAcro = Nothing: Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub