Question : Macro to add certain comments after certain words in MS word doc

Like my other question "Macro to add comment after certain word (s)", I have a document and would like to create a macro that goes through the document, and adds comments for certain words. Unlike the first question, I would like it to add different comments for different words. I also want it to reference an excel worksheet to conduct this operation.

Column A in the worksheet would for example be "GOLD" and "SILVER", and column B in the worksheet would be "AU" and "AG" like chemistry. For every mention of "GOLD" in the document, I want it to add the comment "AU" and for every mention of "SILVER" I want it to add the comment "AG".

The reason I want it to reference an excel worksheet, is because for different projects, I want it to add comments for different words - and the particular words number in the hundreds - is why it should be in an excel worksheet.

So basically, the macro should:

--- for each word in activedocument.range,
---- if it equals a word in column A of my excel worksheet,
----- then add a comment which contains the corresponding column B cell's text

Answer : Macro to add certain comments after certain words in MS word doc

Try the following code:

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:

           
           
             Sub CommentWord()
 
'list of keywords to find
Dim xl As Object
Dim w As Long
Dim wdKeywords() As String
 
Set xl = CreateObject("Excel.Application")
xl.Workbooks.Open ("C:\WordList.xls")   'set to path and file name of your excel file
w = 0
While xl.Sheets(1).Cells(w + 1, 1) <> ""    'assume 1st worksheet in workbook has the word list; words start at cell A1
    ReDim Preserve wdKeywords(1, w)
    wdKeywords(0, w) = xl.Sheets(1).Cells(w + 1, 1) 'store word
    wdKeywords(1, w) = xl.Sheets(1).Cells(w + 1, 2) 'store comment text
    w = w + 1
Wend
xl.ActiveWorkbook.Close 2
xl.Quit
 
Dim wdRange As Range
Dim wdComment As Comment
Dim blnCommentTextFound As Boolean
 
'cycle through each keyword
For w = 0 To UBound(wdKeywords, 2)
    'search body of document
    For Each wdRange In ActiveDocument.Range.Words
        blnCommentTextFound = False
        'if keyword found
        If LCase(Trim(wdRange.Text)) = LCase(wdKeywords(0, w)) Then
            'check if standard comment text has already been added
            For Each wdComment In wdRange.Comments
                If wdComment.Range.Text = wdKeywords(1, w) Then
                    blnCommentTextFound = True
                    Exit For
                End If
            Next wdComment
            'if standard comment text has not been added then add it to the keyword
            If Not blnCommentTextFound Then wdRange.Comments.Add Range:=wdRange, Text:=wdKeywords(1, w)
        End If
    Next wdRange
Next w
 
End Sub

           
         

Open in New Window Select All