Sub Test()
  Highlight "Gregory K. Maxey"
End Sub
Sub Highlight(ByRef strUser As String)
   
  Dim strCheckDoc As String, docRef As Document, docCurrent As Document, trkChg As Boolean
  Dim wrdRef As String, wrdPara As Paragraph, strKeyword As String, strRule As String
  Dim cmtRuleComment As Comment, tbl1 As Table, tbl2 As Table, tbl3 As Table, tbl4 As Table, _
    tbl5 As Table, tbl6 As Table, tbl7 As Table, aRow As Row, aRng As Range
  
  '***
  Dim oRngScope As Range
  
  Set docCurrent = ActiveDocument
  strCheckDoc = "D:\strCheckDoc.docx"
  Debug.Print strCheckDoc
  Set docRef = Documents.Open(strCheckDoc, ReadOnly:=True, Visible:=False)
  If docRef.Tables.Count > 1 Then
    Set tbl1 = docRef.Tables(1) 'Full Application Rules
    Set tbl2 = docRef.Tables(2) 'Background Specific Rules
    Set tbl3 = docRef.Tables(3) 'Summary Specific Rules
    Set tbl4 = docRef.Tables(4) 'Brief Description of the Drawings Specific Rules
    Set tbl5 = docRef.Tables(5) 'Detailed Description Specific Rules
    Set tbl6 = docRef.Tables(6) 'Claim Specific Rules
    Set tbl7 = docRef.Tables(7) 'Abstract Specific Rules
  End If
    
  For Each aRow In tbl1.Rows
    strKeyword = Split(Trim(aRow.Range.Cells(1).Range.Text), vbCr)(0)
    strRule = Split(Trim(aRow.Cells(2).Range.Text), vbCr)(0)
    If strKeyword <> "" Then
      Set aRng = docCurrent.Range
      With aRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Format = True
        .MatchWholeWord = True
        .MatchCase = False
        .MatchWildcards = False '*** True negates MatchCase
        .Text = strKeyword
        Do While .Execute
          aRng.HighlightColorIndex = wdTurquoise
          If strRule <> "" Then
            Set cmtRuleComment = docCurrent.Comments.Add(Range:=aRng, Text:=strUser & ": " & strRule)
            cmtRuleComment.Author = UCase("WordCheck")
            cmtRuleComment.Initial = UCase("WC")
          End If
        Loop
      End With
    End If
  Next aRow
  
  For Each aRow In tbl2.Rows
    strKeyword = Split(Trim(aRow.Range.Cells(1).Range.Text), vbCr)(0)
    strRule = Split(Trim(aRow.Cells(2).Range.Text), vbCr)(0)
    If strKeyword <> "" Then
      Set aRng = GetDocRange(docCurrent, "BACKGROUND", "SUMMARY")
      Set oRngScope = aRng.Duplicate '*** Define the scope
      With aRng.Find
        .Text = strKeyword
        Do While .Execute
          If Not aRng.InRange(oRngScope) Then Exit For '*** You were falling victim of Find's runaway range.
          aRng.HighlightColorIndex = wdTurquoise
          If strRule <> "" Then
            Set cmtRuleComment = docCurrent.Comments.Add(Range:=aRng, Text:=strUser & ": " & strRule)
            cmtRuleComment.Author = UCase("WordCheck")
            cmtRuleComment.Initial = UCase("WC")
          End If
        Loop
      End With
    End If
  Next aRow
  
  For Each aRow In tbl3.Rows
    strKeyword = Split(Trim(aRow.Range.Cells(1).Range.Text), vbCr)(0)
    strRule = Split(Trim(aRow.Cells(2).Range.Text), vbCr)(0)
    If strKeyword <> "" Then
      Set aRng = GetDocRange(docCurrent, "SUMMARY", "DRAWINGS")
      Set oRngScope = aRng.Duplicate
      With aRng.Find
        .Text = strKeyword
        Do While .Execute
          If Not aRng.InRange(oRngScope) Then Exit For
          aRng.HighlightColorIndex = wdTurquoise
          If strRule <> "" Then
            Set cmtRuleComment = docCurrent.Comments.Add(Range:=aRng, Text:=strUser & ": " & strRule)
            cmtRuleComment.Author = UCase("WordCheck")
            cmtRuleComment.Initial = UCase("WC")
          End If
        Loop
      End With
    End If
  Next aRow
  
  For Each aRow In tbl4.Rows
    strKeyword = Split(Trim(aRow.Range.Cells(1).Range.Text), vbCr)(0)
    strRule = Split(Trim(aRow.Cells(2).Range.Text), vbCr)(0)
    If strKeyword <> "" Then
      Set aRng = GetDocRange(docCurrent, "DRAWINGS", "DETAILED")
      Set oRngScope = aRng.Duplicate
      With aRng.Find
        .Text = strKeyword
        Do While .Execute
          If Not aRng.InRange(oRngScope) Then Exit For
          aRng.HighlightColorIndex = wdTurquoise
          If strRule <> "" Then
            Set cmtRuleComment = docCurrent.Comments.Add(Range:=aRng, Text:=strUser & ": " & strRule)
            cmtRuleComment.Author = UCase("WordCheck")
            cmtRuleComment.Initial = UCase("WC")
          End If
        Loop
      End With
    End If
  Next aRow
  
  For Each aRow In tbl5.Rows
    strKeyword = Split(Trim(aRow.Range.Cells(1).Range.Text), vbCr)(0)
    strRule = Split(Trim(aRow.Cells(2).Range.Text), vbCr)(0)
    If strKeyword <> "" Then
      Set aRng = GetDocRange(docCurrent, "DETAILED", "CLAIMS")
      Set oRngScope = aRng.Duplicate
      With aRng.Find
        .Text = strKeyword
        Do While .Execute
          If Not aRng.InRange(oRngScope) Then Exit For
          aRng.HighlightColorIndex = wdTurquoise
          If strRule <> "" Then
            Set cmtRuleComment = docCurrent.Comments.Add(Range:=aRng, Text:=strUser & ": " & strRule)
            cmtRuleComment.Author = UCase("WordCheck")
            cmtRuleComment.Initial = UCase("WC")
          End If
        Loop
      End With
    End If
  Next aRow
  
  For Each aRow In tbl6.Rows
    strKeyword = Split(Trim(aRow.Range.Cells(1).Range.Text), vbCr)(0)
    strRule = Split(Trim(aRow.Cells(2).Range.Text), vbCr)(0)
    If strKeyword <> "" Then
      Set aRng = GetDocRange(docCurrent, "CLAIMS", "ABSTRACT")
      Set oRngScope = aRng.Duplicate
      With aRng.Find
        .Text = strKeyword
        Do While .Execute
          If Not aRng.InRange(oRngScope) Then Exit For
          aRng.HighlightColorIndex = wdTurquoise
          If strRule <> "" Then
            Set cmtRuleComment = docCurrent.Comments.Add(Range:=aRng, Text:=strUser & ": " & strRule)
            cmtRuleComment.Author = UCase("WordCheck")
            cmtRuleComment.Initial = UCase("WC")
          End If
        Loop
      End With
    End If
  Next aRow
  
  For Each aRow In tbl7.Rows
    strKeyword = Split(Trim(aRow.Range.Cells(1).Range.Text), vbCr)(0)
    strRule = Split(Trim(aRow.Cells(2).Range.Text), vbCr)(0)
    If strKeyword <> "" Then
      Set aRng = GetDocRange(docCurrent, "ABSTRACT", "ABSTRACT")
      Set oRngScope = aRng.Duplicate
      With aRng.Find
        .ClearFormatting
        .Text = strKeyword
        Do While .Execute
          If Not aRng.InRange(oRngScope) Then Exit For
          aRng.HighlightColorIndex = wdTurquoise
          If strRule <> "" Then
            Set cmtRuleComment = docCurrent.Comments.Add(Range:=aRng, Text:=strUser & ": " & strRule)
            cmtRuleComment.Author = UCase("WordCheck")
            cmtRuleComment.Initial = UCase("WC")
          End If
        Loop
      End With
    End If
  Next aRow
  
  docRef.Close
  docCurrent.Activate
           
End Sub

Function GetDocRange(aDoc As Document, startWord As String, endWord As String) As Range
  Dim aRng As Word.Range, iStart As Long, iEnd As Long
  Set aRng = aDoc.Range
  With aRng.Find
    .ClearFormatting
    .Wrap = wdFindStop
    .MatchCase = True
    .MatchWildcards = False
    .Text = startWord
    If .Execute Then iStart = aRng.End
    aRng.End = aDoc.Range.End
    .Text = endWord
    If .Execute Then iEnd = aRng.Start
    If startWord = "ABSTRACT" Then iEnd = aDoc.Range.End
    If iEnd > iStart Then
      Set GetDocRange = aDoc.Range(iStart, iEnd)
    End If
  End With
End Function