macro for performing more than one find and replace procedure at the same time

Thanks again for your help with the find-and-comment-from-list macro, Greg. Deleting that line fixed the character limit issue.

I've been trying to shift from a Word-based database to an Excel-based one. I added the Excel object library to my references, but I can't seem to figure out the analogous Excel objects to "translate" the macro (e.g. "Sheets" vs. "Table," etc.). I'm new to VBA so my method is just trial-and-error (and so far no trial-and-success). Any suggestions?

Assuming a simple Excel file with a header row starting at A1 with column A being the words or phrases to find and column B the associated comments, then the following will work. It uses the function to read the named worksheet into an array, then uses the array to provide the search and comment texts. By using this method, the process is very much faster than attempting to open and process the workbook line by line. It needs no reference to Excel.

Option Explicit

Sub FindAndCommentFromXLList()

'A Word macro by Graham Mayor

'Requires Function xlFillArray

Dim oDoc As Document

Dim oRng As Range

Dim i As Long

Dim Arr() As Variant

Dim sFindText As String

Dim sCommentText As String

Const strWorkbook As String = "C:\Path\Comments.xlsx"

Const strSheet As String = "Sheet1"

    Set oDoc = ActiveDocument

    Arr = xlFillArray(strWorkbook, strSheet)

    For i = 0 To UBound(Arr, 2)

        sFindText = Arr(0, i)

        sCommentText = Arr(1, i)

        If Len(sCommentText) > 255 Then

            sCommentText = Left(sCommentText, 255)

        End If

        Set oRng = ActiveDocument.Range

        With oRng.Find

            .ClearFormatting

            .Replacement.ClearFormatting

            Do While .Execute(FindText:=sFindText, _

                              MatchWholeWord:=True, _

                              Forward:=True, _

                              Wrap:=wdFindStop) = True

                oRng.Comments.Add oRng, sCommentText

                oRng.Collapse wdCollapseEnd

                DoEvents

            Loop

        End With

    Next i

lbl_Exit:

    Exit Sub

End Sub

Private Function xlFillArray(strWorkbook As String, _

                             strWorksheetName As String) As Variant

Dim RS As Object

Dim CN As Object

Dim iRows As Long

    strWorksheetName = strWorksheetName & "$]"

    Set CN = CreateObject("ADODB.Connection")

    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _

                              "Data Source=" & strWorkbook & ";" & _

                              "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

    Set RS = CreateObject("ADODB.Recordset")

    RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

    With RS

        .MoveLast

        iRows = .RecordCount

        .MoveFirst

    End With

    xlFillArray = RS.GetRows(iRows)

    If RS.State = 1 Then RS.Close

    Set RS = Nothing

    If CN.State = 1 Then CN.Close

    Set CN = Nothing

lbl_Exit:

    Exit Function

End Function

Thanks, Graham, this seems to be working perfectly. 

Just one follow-up question: how do I preserve hyperlinks in comments?

I'm using the macro to help users reference a style guide, and the long entries are hard to read in Word comments, so I'd rather point users to the entry online.

For anyone reading this who's interested in doing both find-and-comment and find-and-replace, I have that working using a single Excel file with separate sheets for each function.

I'm using Graham's "FindAndCommentFromXLList" macro and "xlFillArray" function in conjunction with the macro below (not sure if the two macros could or should be combined into one, but the easy solution is to make a third macro that simply calls the other two).

To avoid confusion I renamed the sheets "comment" and "replace," so I had to change "sheet1" in Graham's code to "comment."

Sub FindAndReplaceFromXLList()

'

' requires Function xlFillArray

'

'

Dim oDoc As Document

Dim oRng As Range

Dim i As Long

Dim Arr() As Variant

Dim sFindText As String

Dim sReplaceText As String

Const strWorkbook As String = "C:\YOURPATHHERE\YOURFILEHERE.xlsx"

Const strSheet As String = "replace"

    Set oDoc = ActiveDocument

    Arr = xlFillArray(strWorkbook, strSheet)

    For i = 0 To UBound(Arr, 2)

        sFindText = Arr(0, i)

        sReplaceText = Arr(1, i)

        Set oRng = ActiveDocument.Range

        With oRng.Find

            .ClearFormatting

            .Replacement.ClearFormatting

            Do While .Execute(FindText:=sFindText, _

                              MatchWholeWord:=True, _

                              Forward:=True, _

                              Wrap:=wdFindStop) = True

                oRng.Text = sReplaceText

                oRng.Collapse wdCollapseEnd

                DoEvents

            Loop

        End With

    Next i

lbl_Exit:

    Exit Sub

End Sub