Insert Comments from List for Whole Document and for Only Selected Portion of Document

Guessed · #1 11-09-2020, 04:21 PM

I added some structure to both your docs to make the coding more forgiving. In the DocToCheck, I bookmarked the range where your list is. In the PrefsDoc I added tables to restrict the two separate loops more easily. Then the following code should do what you asked.

Code:

Sub Highlight()

  Application.ScreenUpdating = False
  
  Dim strCheckDoc As String, docRef As Document, docCurrent As Document
  Dim wrdRef As String, wrdPara As Paragraph, strKeyword As String, strRule As String
  Dim cmtRuleComment As Comment, tbl1 As Table, tbl2 As Table, aRow As Row, aRng As Range
  
  Set docCurrent = ActiveDocument
  strCheckDoc = docCurrent.Path & "\PreferencesDocument1.docx"
  Debug.Print strCheckDoc
  Set docRef = Documents.Open(strCheckDoc, ReadOnly:=True, Visible:=False)
  If docRef.Tables.Count > 1 Then
    Set tbl1 = docRef.Tables(1)
    Set tbl2 = docRef.Tables(2)
  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
        .Text = strKeyword
        Do While .Execute
          aRng.HighlightColorIndex = wdTurquoise
          If strRule <> "" Then
            Set cmtRuleComment = docCurrent.Comments.Add(Range:=aRng, Text:=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 = docCurrent.Bookmarks("ListArea").Range
      With aRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Format = True
        .MatchWholeWord = True
        .MatchCase = False
        .MatchWildcards = False
        .Text = strKeyword
        Do While .Execute
          aRng.HighlightColorIndex = wdYellow
          If strRule <> "" Then
            Set cmtRuleComment = docCurrent.Comments.Add(Range:=aRng, Text:=strRule)
            cmtRuleComment.Author = UCase("WordCheck")
            cmtRuleComment.Initial = UCase("WC")
          End If
        Loop
      End With
    End If
  Next aRow
  
  docRef.Close
  docCurrent.Activate
  
  Application.ScreenUpdating = True
  
  Exit Sub

End Sub

rekent · #2 11-09-2020, 08:56 PM

Would it be possible to create the bookmark for DocumentToCheck dynamically within the code based on the preceding and following headings? I need to be able to run this without the document including special elements, instead just having the document's normal formatting and structure.

Could the word LIST in uppercase be found, the list ABSTRACT in uppercase be found, a range defined from immediately following the last character of LIST to immediately preceding the first character of ABSTRACT, and then add the bookmark to that range? (Not that I know how to write the code to define the range that I just suggested...)

Edit: I think this code should achieve what I describe above (searching up from the bottom of the document), but VBE is not cooperating at the moment.

Code:

Dim startPosition As Long, endPosition As Long, listRange As Range

Selection.EndKey Unit:=wdStory

With Selection.Find
        .ClearFormatting
        .Forward = Flase
        .Format = True
        .MatchWholeWord = True
        .MatchCase = True
        .MatchWildcards = False
        .Execute FindText:=uCase("ABSTRACT")

endPosition = Selection.Range.Start

With Selection.Find
        .ClearFormatting
        .Forward = False
        .Format = True
        .MatchWholeWord = True
        .MatchCase = True
        .MatchWildcards = False
        .Execute FindText:=uCase("LIST")

startPosition = Selection.Range.End

listRange.SetRange Start:=startPosition, End:=endposition
ActiveDocument.Bookmarks.Add Name:="ListArea", Range:=listRange

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Reveal portion of document based on dropdown selection	chappeja	Word VBA	1	03-27-2019 08:36 PM
Renumber document at annex portion of document	jeffreybrown	Word	3	02-14-2019 05:53 AM
How do you add XML Schema Tags to Certain portion of a Word Document?	Anishgirijan	Word VBA	0	02-08-2017 10:38 PM
How can I link a portion of a word document to another word document and have it auto update?	__Data	Word	1	06-30-2015 11:03 PM
Save as PDF only saves portion of document	pandro	Word	0	10-08-2014 06:54 AM