Wsrtjtyk

I have a two dimensional array comprised of "trouble" words and phrases in the first dimension and the comments I frequently make in the second dimension. I seem to be lost at how to select the text that matches the first dimension and add the comment using the text from the second dimension. Any ideas?

Sub findtrouble()

Dim i As Integer

Dim j As Integer

Dim oRng As Word.Range







Dim MyArray(1, 4) As String

MyArray(0, 0) = "Trouble0"

MyArray(0, 1) = "Trouble1"

MyArray(0, 2) = "Trouble2"

MyArray(0, 3) = "Trouble3"



MyArray(1, 0) = "Comment0"

MyArray(1, 1) = "Comment1"

MyArray(1, 2) = "Comment2"

MyArray(1, 3) = "Comment3"







For j = 0 To 4

        Set oRng = ActiveDocument.Range

        With oRng.Find

            .ClearAllFuzzyOptions

            .ClearFormatting

            .Text = MyArray(0, j)

        While .Execute

            oRng.Select

            ActiveDocument.Comments.Add oRng, MyArray(1, j)    

        Wend

    End With

    Debug.Print "Find: " & MyArray(0, j) & " add cmt box w/ "; MyArray(1, j)

Next j



End Sub

The code in the question does insert one comment for me, but that's all. It's because oRng isn't being reset. Compare the code in the question to that below.

In this code, after Find.Execute is successful and the comment added the range is collapsed to it endpoint (after the found term) then the end extended to the end of the document. In this way, the next time the term is searched it looks only in what follows the first term.

It's also important when looping in Find to set the Find.Wrap to wdFindStop to avoid going into an "infinite loop" (so that Find doesn't start again at the top of the document).

Sub findtrouble()

Dim i As Integer

Dim j As Integer

Dim oRng As Word.Range



Dim MyArray(1, 4) As String

MyArray(0, 0) = "Trouble0"

MyArray(0, 1) = "Trouble1"

MyArray(0, 2) = "Trouble2"

MyArray(0, 3) = "Trouble3"



MyArray(1, 0) = "Comment0"

MyArray(1, 1) = "Comment1"

MyArray(1, 2) = "Comment2"

MyArray(1, 3) = "Comment3"



For j = 0 To 4

        Set oRng = ActiveDocument.Content

        With oRng.Find

            .ClearAllFuzzyOptions

            .ClearFormatting

            .text = MyArray(0, j)

            .wrap = wdFindStop

            While .Execute

                oRng.Select

                ActiveDocument.Comments.Add oRng, MyArray(1, j)

                oRng.Collapse wdCollapseEnd

                oRng.End = ActiveDocument.content.End

            Wend

        End With

    Debug.Print "Find: " & MyArray(0, j) & " add cmt box w/ "; MyArray(1, j)

Next j



End Sub

As per @Cindy Meisters' comment the posted code does work (even with the indexing error in the for loop). The code below is the same rewritten to use a scripting.dictionary

Sub testfindtrouble()

    findtrouble ActiveDocument.Range

End Sub

Sub findtrouble(this_range As Word.Range)

Dim my_lookup       As scripting.Dictionary

Dim my_troubles     As Variant

Dim my_trouble      As Variant

Dim my_range        As Word.Range



' see https://stackoverflow.com/questions/53317548/how-to-delete-a-section-using-excel-vba-to-create-a-word-document/53322166?noredirect=1#comment93559248_53322166

    Set my_lookup = New scripting.Dictionary



    With my_lookup



        .Add key:="Trouble0", item:="Comment0"

        .Add key:="Trouble1", item:="Comment1"

        .Add key:="Trouble2", item:="Comment2"

        .Add key:="Trouble3", item:="Comment3"



    End With



    my_troubles = my_lookup.Keys



    ' Avoid the off by 1 error (j=0 to 4 is 5 items not the 4 you declared in the array

    For Each my_trouble In my_troubles



        Set my_range = this_range.Duplicate



        With my_range



            With .Find



                .ClearAllFuzzyOptions

                .ClearFormatting

                .text = my_trouble

                .Execute



            End With



            Do While .Find.Found



                 Debug.Print "Find: " & my_trouble & " add cmt box w/ "; my_lookup.item(my_trouble)

                .Comments.Add .Duplicate, my_lookup.item(my_trouble)

                .Collapse Direction:=wdCollapseEnd

                .Move unit:=wdCharacter, Count:=1

                .Find.Execute



            Loop



        End With



    Next



End Sub