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 i As Long, j As Long, StrOut As String, StrBreak As String
 
StrOut = "Term" & vbTab & "Pages" & vbTab & "Term" & vbTab & "Pages" & vbCr
Set Doc = ActiveDocument
Set RefDoc = Documents.Open("Drive:\FilePath\KeyTerms.doc", AddtorecentFiles:=False)
StrTerms = RefDoc.Range.Text
RefDoc.Close False
Set RefDoc = Nothing
 
' I think this searches the content of the document against the terms of ref doc. strFind loops each term one at a time
For i = 0 To UBound(Split(StrTerms, vbCr))
  strFnd = Trim(Split(StrTerms, vbCr)(i))
  If strFnd = "" Then GoTo NullString
  StrPages = ""
  With Doc.Content
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = False
      .Text = strFnd
      .Wrap = wdFindStop
      .MatchWholeWord = True
      .MatchWildcards = False
      .MatchCase = True
      .Execute
    End With
 
' I think this counts the page numbers if there is more than 1 reference to the term?
    j = 0
    Do While .Find.Found
      If j <> .Duplicate.Information(wdActiveEndPageNumber) Then
        j = .Duplicate.Information(wdActiveEndPageNumber)
        StrPages = StrPages & j & " "
      End If
      .Find.Execute
    Loop
 
'I think this splits out the page numbers after the term with a space then a comma and space between each page number?
    StrPages = Replace(Trim(StrPages), " ", ",")
    If StrPages <> "" Then
      If i Mod 2 = 0 Then StrBreak = vbTab Else StrBreak = vbCr
      StrOut = StrOut & strFnd & vbTab & ParsePageRefs(StrPages) & StrBreak
    End If
  End With
 
NullString:
Next I
 
' I think this creates the table ? (Will I need 4 columns)
Set Rng = Doc.Range.Characters.Last
With Rng
  .InsertAfter vbCr & Chr(12) & StrOut
  .Start = .Start + 2
  .ConvertToTable Separator:=vbTab, Numcolumns:=4, AutoFitBehavior:=wdAutoFitContent, AutoFit:=True
  With .Tables(1).Rows.First.Range
    .ParagraphFormat.Alignment = wdAlignParagraphCenter
    .Font.Bold = True
  End With
End With
 
Application.ScreenUpdating = True
End Sub
 
 
' I have no idea what this is doing??????????????
Function ParsePageRefs(StrPages As String)
Dim ArrTmp(), i As Integer, j As Integer, k As Integer
ReDim ArrTmp(UBound(Split(StrPages, ",")))
For i = 0 To UBound(Split(StrPages, ","))
  ArrTmp(i) = Split(StrPages, ",")(i)
Next
For i = 0 To UBound(ArrTmp) - 1
  If IsNumeric(ArrTmp(i)) Then
    k = 2
    For j = i + 2 To UBound(ArrTmp)
      If CInt(ArrTmp(i) + k) <> CInt(ArrTmp(j)) Then Exit For
      ArrTmp(j - 1) = ""
      k = k + 1
    Next
    i = j - 1
  End If
Next
ParsePageRefs = Replace(Replace(Replace(Replace(Join(ArrTmp, ","), ",,", " "), " ,", " "), "  ", " "), " ", "-")
End Function

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