Sub TabulateKeyTerms()
Application.ScreenUpdating = False
Dim Doc As Document, RefDoc As Document, Rng As Range
Dim StrTerms As String, strFnd As String, StrPages As String
Dim r As Long, j As Long, StrOut As String, StrBreak As String
Set Doc = ActiveDocument
Set RefDoc = Documents.Open("Drive:\FilePath\KeyTerms.doc", ReadOnly:=True, AddToRecentFiles:=False)
For r = RefDoc.Tables(1).Rows.Count To 1 Step -1
  strFnd = Trim(Split(RefDoc.Tables(1).Cell(r, 1).Range.Text, vbCr)(0))
  With Doc.Content
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = False
      .Text = strFnd
      .Wrap = wdFindStop
      .MatchWholeWord = True
      .MatchWildcards = False
      .MatchCase = True
      .Execute
    End With
    If .Find.Found = False Then RefDoc.Tables(1).Rows(r).Delete
Next r
Set Rng = Doc.Range.Characters.Last
Rng.FormattedText = RefDoc.Tables(1).Range.FormattedText
RefDoc.Close False
Set Rng = Nothing: Set RefDoc = Nothing
Application.ScreenUpdating = True
End Sub