The below code is supposed to search the attached WorkingDoc.docx based on the attached strCheckDoc.docx. Words in the left column of strCheckDoc are found and highlighted, and contents of the right column for a given row are added as a comment to the highlighted word. The search is supposed to be performed in a range that is defined according to the headers that bound respective sections of WorkingDoc.
There are currently two issues that I haven't been able to track down resolutions for:
1) MatchCase = False is set, but the search is still acting case sensitive. For example, fullapplicationword is not being found based on the search for Fullapplicationword.
2) The GetDocRange function does not appear to be correctly setting the end of aRng. For example, backgroundword is found in all sections beginning with and following the BACKGROUND section instead of just in the range between "BACKGROUND" and "SUMMARY," summaryword is found in all sections beginning with and following the SUMMARY section instead of just in the range between "SUMMARY" and "DRAWINGS," etc.
Does anyone see what I could be missing to result in the above errors?
Code:
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
Set docCurrent = ActiveDocument
strCheckDoc = [path to strCheckDoc document]
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 = True
.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")
With aRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = False
.MatchWildcards = True
.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 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")
With aRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = False
.MatchWildcards = True
.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 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")
With aRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = False
.MatchWildcards = True
.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 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")
With aRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = False
.MatchWildcards = True
.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 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")
With aRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = False
.MatchWildcards = True
.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 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")
With aRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = False
.MatchWildcards = True
.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
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