Word macro loop hanging inside table cell

Question

Hello everyone --

Jay Freedman kindly helped me with my searching-for-text-between-quotes Word macro last Friday, 6/7/13.  (Jay, are you there to help me again?)  It  works great until it comes to a table with quoted text inside a table cell--then it underlines the appropriate text, but does not move on from that cell.  Is there a way to tweak my macro to enable it to handle tables (and footnotes?). 

Any help would be really appreciated.

Thank you.   -Lynne

Here is the code:

Sub TermByTerm()

    Dim SearchAndReplaceRng As Range

    Dim FixCommaRng As Range

    Set SearchAndReplaceRng = ActiveDocument.Content

    With SearchAndReplaceRng.Find

        .ClearFormatting

        .Text = "[^0034^0147]*[^0034^0148]" '<-- Search for text between quotes

        .Forward = True

        .Wrap = wdFindStop

        .MatchWildcards = True

        While .Execute

            With SearchAndReplaceRng

                .MoveEnd Unit:=wdCharacter, Count:=-1

                .MoveStart Unit:=wdCharacter, Count:=1

                .Select  ' <-- bring it into view

                .Font.Underline = wdUnderlineSingle

                Set FixlCommaRng = SearchAndReplaceRng.Duplicate

                With FixPuncuationRng.Find

                    .Format = True

                    .Text = ","

                    .Font.Underline = True

                    .Replacement.Text = ","

                    .Replacement.Font.Underline = wdUnderlineNone

                    .Execute Replace:=wdReplaceAll

                End With

                If MsgBox(Prompt:="Continue?", Buttons:=vbYesNo) = vbNo Then Exit Sub

                .Start = .End + 2  ' <-- next search starting after the current closing quote

                .End = ActiveDocument.Content.End  ' <-- and continuing to the end of the document

            End With

        Wend

    End With

End Sub

Answer 1

Jay, thank you again!  (I have been away and was able to see your email just now.)  I tested it, and so far, it works perfectly.    I will go through your section taking care of tables, following along with F8 and learn how that works.

I could NEVER have done it without your help!

Many, many thanks!    :-D

-Lynne

Answer 2

Yes, that was a helpful description.

My mistake was in the part of the code that tries to search for more quoted strings within the same table cell where I've already found one,

                    If .End < aCell.Range.End - 3 Then

                        .Start = .End + 2

                        .End = aCell.Range.End - 1

                    Else

If there were no more quoted items in the same cell, then the next .Execute would return False, causing the macro to stop looking for any more items in the main part of the document and go on to the footnote-searching code. I think I've fixed that, although I'm not terribly happy with how complex the code has gotten. Try this:

Sub TermByTerm()

    Dim SearchAndReplaceRng As Range

    Dim FixCommaRng As Range

    Dim aCell As Cell

    Set SearchAndReplaceRng = ActiveDocument.Content

    With SearchAndReplaceRng.Find

        .ClearFormatting

        .Text = "[^0034^0147]*[^0034^0148]" '<-- Search for text between quotes

        .Forward = True

        .Wrap = wdFindStop

        .MatchWildcards = True

        While .Execute

            With SearchAndReplaceRng

                MarkFind FoundRg:=SearchAndReplaceRng

                If MsgBox(Prompt:="Continue?", Buttons:=vbYesNo) = vbNo Then

                    If MsgBox(Prompt:="Check footnotes?", Buttons:=vbYesNo) = vbYes Then

                        GoTo SearchFootnotes

                    Else

                        Exit Sub

                    End If

                End If

                If .Information(wdWithInTable) Then

                    Set aCell = .Tables(1).Cell( _

                        .Information(wdEndOfRangeRowNumber), _

                        .Information(wdEndOfRangeColumnNumber))

                    Do While .End < aCell.Range.End - 3

                        .Start = .End + 2

                        .End = aCell.Range.End - 1

                        If .Find.Execute Then

                            MarkFind FoundRg:=SearchAndReplaceRng

                            If MsgBox(Prompt:="Continue?", Buttons:=vbYesNo) = vbNo Then

                                If MsgBox(Prompt:="Check footnotes?", Buttons:=vbYesNo) = vbYes Then

                                    GoTo SearchFootnotes

                                Else

                                    Exit Sub

                                End If

                            End If

                        Else

                            Exit Do

                        End If

                    Loop

                    On Error GoTo LeaveTable

                    Set aCell = aCell.Next

                    While InStr(aCell.Range.Text, Chr(34)) = 0 And InStr(aCell.Range.Text, Chr(147)) = 0

                        Set aCell = aCell.Next

                        .Start = aCell.Range.Start

                        .End = aCell.Range.End - 1

                    Wend

                Else

                    .Start = .End + 2  ' <-- next search starting after the current closing quote

                    .End = ActiveDocument.Content.End  ' <-- and continuing to the end of the document

                End If

                GoTo MyResume

LeaveTable:

                Err.Clear

                .Start = .Tables(1).Range.End + 1

                .End = ActiveDocument.Content.End

MyResume:

            End With

        Wend

    End With

SearchFootnotes:

    Set SearchAndReplaceRng = ActiveDocument.StoryRanges(wdFootnotesStory)

    With SearchAndReplaceRng.Find

        .ClearFormatting

        .Text = "[^0034^0147]*[^0034^0148]" '<-- Search for text between quotes

        .Forward = True

        .Wrap = wdFindStop

        .MatchWildcards = True

        While .Execute

            With SearchAndReplaceRng

                MarkFind FoundRg:=SearchAndReplaceRng

                If MsgBox(Prompt:="Continue?", Buttons:=vbYesNo) = vbNo Then Exit Sub

                .Start = .End + 2  ' <-- next search starting after the current closing quote

                .End = ActiveDocument.StoryRanges(wdFootnotesStory).End  ' <-- and continuing to the end of the document

            End With

        Wend

    End With

End Sub

Private Sub MarkFind(FoundRg As Range)

    Dim FixCommaRng As Range

    With FoundRg

         .MoveEnd Unit:=wdCharacter, Count:=-1

         .MoveStart Unit:=wdCharacter, Count:=1

         .Select  ' <-- bring it into view

         .Font.Underline = wdUnderlineSingle

         Set FixCommaRng = FoundRg.Duplicate

         With FixCommaRng.Find

             .Format = True

             .Text = ","

             .Font.Underline = True

             .Replacement.Text = ","

             .Replacement.Font.Underline = wdUnderlineNone

             .Execute Replace:=wdReplaceAll

         End With

    End With

End Sub

Answer 3

Hi, Jay -- Well, the macro is still going awry.  To test it, I made a 4-page document with:

-footnotes on pp. 1, 4;

-a quoted term in the main text at the top of page 3;

-a table in middle of page 3 with 2 quoted terms in different rows;

-and more main text with quoted terms after the table and on page 4.

I've followed along using F8, and it:

1-finds the first quoted term on page 3, underlines it & de-underlines the comma, prompts for Yes/No to continue;

(click Yes)

2-pops down to MYRESUME: ;

3-pops back up to the main While;

4-finds the first quoted term in the table on page 3, underlines & de-underlines the comma,

5-moves down to Wend, then to End With;

6-pops up to the SEARCHFOOTNOTES While;

7-drops now to the prompt for Yes/No to continue;

(click Yes)

8-loops through the footnotes, prompting Yes/No to Continue each time until no more footnotes, and then the macro ends.

After the macro is finished, the document has the following:

-the quoted term on page 3 underlined properly;

-the first term, only, of the table underlined (second quoted term not underlined);

-all of the quoted text in the foonotes underlined.

-none of the quoted terms in the main text on page 4 underlined.

Are the above notes helpful? 

Any further help you could offer, I'd really appreciate!

Thank you so much,

-Lynne

Answer 4

Wow--Hi, Jay, and thank you!

I will test this new code and let you know as soon as I can.

-Lynne

Answer 5

I'm almost always here. :-)

Adding tables and footnotes to the mix makes the macro considerably longer, but not impossible. By the way, use copy and paste, not retyping, to transfer the code to the VBA editor. I see two typos (if that's what they are) in your last post that would cause errors -- the variables FixlCommaRng and FixPuncuationRng are not defined.

Try this code with your documents, and let me know if anything else goes wrong. I know, for example, that there could be a problem if a table cell contains an odd number of straight quotes or an unmatched "smart" quote.

Sub TermByTerm()

    Dim SearchAndReplaceRng As Range

    Dim FixCommaRng As Range

    Dim aCell As Cell

    Set SearchAndReplaceRng = ActiveDocument.Content

    With SearchAndReplaceRng.Find

        .ClearFormatting

        .Text = "[^0034^0147]*[^0034^0148]" '<-- Search for text between quotes

        .Forward = True

        .Wrap = wdFindStop

        .MatchWildcards = True

        While .Execute

            With SearchAndReplaceRng

                .MoveEnd Unit:=wdCharacter, Count:=-1

                .MoveStart Unit:=wdCharacter, Count:=1

                .Select  ' <-- bring it into view

                .Font.Underline = wdUnderlineSingle

                Set FixCommaRng = SearchAndReplaceRng.Duplicate

                With FixCommaRng.Find

                    .Format = True

                    .Text = ","

                    .Font.Underline = True

                    .Replacement.Text = ","

                    .Replacement.Font.Underline = wdUnderlineNone

                    .Execute Replace:=wdReplaceAll

                End With

                If MsgBox(Prompt:="Continue?", Buttons:=vbYesNo) = vbNo Then

                    If MsgBox(Prompt:="Check footnotes?", Buttons:=vbYesNo) = vbYes Then

                        GoTo SearchFootnotes

                    Else

                        Exit Sub

                    End If

                End If

                If .Information(wdWithInTable) Then

                    Set aCell = .Tables(1).Cell( _

                        .Information(wdEndOfRangeRowNumber), _

                        .Information(wdEndOfRangeColumnNumber))

                    If .End < aCell.Range.End - 3 Then

                        .Start = .End + 2

                        .End = aCell.Range.End - 1

                    Else

                        On Error GoTo LeaveTable

                        .Start = aCell.Next.Range.Start

                        .End = aCell.Next.Range.End - 1

                        While InStr(aCell.Range.Text, Chr(34)) = 0 And InStr(aCell.Range.Text, Chr(147)) = 0

                            Set aCell = aCell.Next

                        Wend

                    End If

                    GoTo MyResume

LeaveTable:

                    Err.Clear

                    .Start = .Tables(1).Range.End + 1

                    .End = ActiveDocument.Content.End

MyResume:

                Else

                    .Start = .End + 2  ' <-- next search starting after the current closing quote

                    .End = ActiveDocument.Content.End  ' <-- and continuing to the end of the document

                End If

            End With

        Wend

    End With

SearchFootnotes:

    Set SearchAndReplaceRng = ActiveDocument.StoryRanges(wdFootnotesStory)

    With SearchAndReplaceRng.Find

        .ClearFormatting

        .Text = "[^0034^0147]*[^0034^0148]" '<-- Search for text between quotes

        .Forward = True

        .Wrap = wdFindStop

        .MatchWildcards = True

        While .Execute

            With SearchAndReplaceRng

                .MoveEnd Unit:=wdCharacter, Count:=-1

                .MoveStart Unit:=wdCharacter, Count:=1

                .Select  ' <-- bring it into view

                .Font.Underline = wdUnderlineSingle

                Set FixCommaRng = SearchAndReplaceRng.Duplicate

                With FixCommaRng.Find

                    .Format = True

                    .Text = ","

                    .Font.Underline = True

                    .Replacement.Text = ","

                    .Replacement.Font.Underline = wdUnderlineNone

                    .Execute Replace:=wdReplaceAll

                End With

                If MsgBox(Prompt:="Continue?", Buttons:=vbYesNo) = vbNo Then Exit Sub

                .Start = .End + 2  ' <-- next search starting after the current closing quote

                .End = ActiveDocument.StoryRanges(wdFootnotesStory).End  ' <-- and continuing to the end of the document

            End With

        Wend

    End With

End Sub