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