Do While macro stuck in infinite loop

Question

Hi, 

I need to enclose italic strings in < and >. Using a found macro from 2002--too old, I guess--I wrote this:

With Selection.Find

 .ClearFormatting

 .Text = ""

 .Font.Italic = True

 .Replacement.Text = ""

 .Forward = True

 .Wrap = wdFindContinue

 .Format = True

 .MatchWildcards = False

End With

Selection.Find.Execute

Do While Selection.Find.Found

 Selection.InsertBefore "<"

 Selection.InsertAfter ">"

Selection.Find.Execute

Loop

End Sub

But this creates an infinite loop and crashes Word. Help?

Answer 1

This should do it:

Sub doiteverywhere()

Dim myStoryRange As Range

'First search the main document using the Selection

Selection.HomeKey wdStory

Selection.Find.ClearFormatting

Selection.Find.Font.Italic = True

With Selection.Find

    Do While .Execute(FindText:="", MatchWildcards:=False, Forward:=True, Wrap:=wdFindStop) = True

        With Selection

            .InsertBefore "<"

            .InsertAfter ">"

            .Collapse wdCollapseEnd

        End With

    Loop

End With

'Now search all other stories using Ranges

For Each myStoryRange In ActiveDocument.StoryRanges

    If myStoryRange.StoryType <> wdMainTextStory Then

        myStoryRange.Select

        Selection.Collapse wdCollapseStart

        With Selection.Find

            Do While .Execute(FindText:="", MatchWildcards:=False, Forward:=True, Wrap:=wdFindStop) = True

                With Selection '.Range

                    .InsertBefore "<"

                    .InsertAfter ">"

                    .Collapse wdCollapseEnd

                End With

            Loop

        End With

        Do While Not (myStoryRange.NextStoryRange Is Nothing)

            Set myStoryRange = myStoryRange.NextStoryRange

            myStoryRange.Select

            Selection.Collapse wdCollapseStart

            With Selection.Find

                Do While .Execute(FindText:="", MatchWildcards:=False, Forward:=True, Wrap:=wdFindStop) = True

                    With Selection '.Range

                        .InsertBefore "<"

                        .InsertAfter ">"

                        .Collapse wdCollapseEnd

                    End With

                Loop

            End With

         Loop

     End If

Next myStoryRange

ActiveWindow.View = wdPrintView

Selection.HomeKey wdStory

End Sub

Answer 2

Thanks, but I'm not at all sure how to merge your macro above with the template given on that web page. Here's my first shot at it, which I'm sure is wrong:

Dim myStoryRange As Range

For Each myStoryRange In ActiveDocument.StoryRanges

myStoryRange.Find.ClearFormatting

myStoryRange.Find.Font.Italic = True

With myStoryRange.Find

    Do While .Execute(FindText:="", MatchWildcards:=False, Forward:=True, Wrap:=wdFindStop) = True

        With Selection

            .InsertBefore "<"

            .InsertAfter ">"

            .Collapse wdCollapseEnd

        End With

    Loop

End With

Any clues?

Answer 3

See the article "Using a macro to replace text where ever it appears in a document including Headers, Footers, Textboxes, etc.” at:

http://www.word.mvps.org/FAQs/MacrosVBA/FindReplaceAllWithVBA.htm

Answer 4

Thanks so much! Works beautifully. One question, though: would there be a way to loop this through all story ranges? Or am I pushing my luck?

Answer 5

Use:

Selection.HomeKey wdStory

Selection.Find.ClearFormatting

Selection.Find.Font.Italic = True

With Selection.Find

    Do While .Execute(FindText:="", MatchWildcards:=False, Forward:=True, Wrap:=wdFindStop) = True

        With Selection

            .InsertBefore "<"

            .InsertAfter ">"

            .Collapse wdCollapseEnd

        End With

    Loop

End With