word macro crashes when 'while' loop is executed - vba

Question

I have a VBA macro(Word2010) script to highlight all the text in italics. But when executed in large file say a document with more than 10 pages the Word get crashed.
I have used the below code for this purpose.
Sub Italics_Highlight()
'
' test_italics_highlight_ Macro
'
'
Application.ScreenUpdating = False
Dim myString As Word.Range
Set myString = ActiveDocument.Content
With myString.Find
.ClearFormatting
.Text = ""
.Font.Italic = True
While .Execute
myString.HighlightColorIndex = wdTurquoise
myString.Collapse wdCollapseEnd
Wend
End With
MsgBox "Thank you!"
End Sub
Could you please help to overcome this. Thanks for your help in advance.

Answer 1

Your error description looks like your code is running forever and doesn't finish.
You might want to add a DoEvents inside your While loop to keep Word responsive while running the code.
With myString.Find
.ClearFormatting
.Text = ""
.Font.Italic = True
While .Execute
DoEvents 'keeps Word responsive
myString.HighlightColorIndex = wdTurquoise
myString.Collapse wdCollapseEnd
Wend
End With
I'm not sure if your code will ever stop. The loop might not stop at the end of the document but start again from beginning, and therefore always find something italic again and again, looping forever.
So you might need to set the .Wrap = wdFindStop to stop at the end of the document.
See Find.Wrap Property (Word).
With myString.Find
.ClearFormatting
.Text = ""
.Font.Italic = True
.Wrap = wdFindStop 'stop at the end of the document
While .Execute
DoEvents 'keeps Word responsive
myString.HighlightColorIndex = wdTurquoise
myString.Collapse wdCollapseEnd
Wend
End With

Answer 2

You don't need to stop at each "found" and apply highlighting. You can do it as part of a Find/Replace:
Sub testInfiniteLoop()
Dim myString As word.Range
Set myString = ActiveDocument.content
Options.DefaultHighlightColorIndex = wdTurquoise
With myString.Find
.ClearFormatting
.Text = ""
.Font.Italic = True
.Replacement.Text = ""
.Replacement.Highlight = wdTurquoise
.wrap = wdFindStop 'stop at the end of the document
.Execute Replace:=wdReplaceAll
End With
End Sub

Answer 3

The following code not only highlights but also restores whatever highlight settings were previously in force:
Sub Italics_Highlight()
Application.ScreenUpdating = False
Dim i As Long: i = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdTurquoise
With ActiveDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = "^&"
.Replacement.Highlight = True
.Format = True
.Font.Italic = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Options.DefaultHighlightColorIndex = i
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
As you can see, you also don't need:
Dim myString As Word.Range
Set myString = ActiveDocument.Content