Find and Replace macro problem

[bobby23]

Hello

I've been working on this macro for some time and found that it sometimes falls into infinite loop. Could someone help me out with a suggestion.
Her's the code:

Sub replacing ()
Dim rngStory As Word.Range
Application.ScreenUpdating = False
For Each rngStory In ActiveDocument.StoryRanges
Do


With rngStory.Find

.ClearFormatting
.Highlight = True
.Wrap = Word.WdFindWrap.wdFindStop
.Execute
While .Found = True


If rngStory.HighlightColorIndex = wdRed Then

rngStory.Font.ColorIndex = wdRed


End If
rngStory.Collapse wdCollapseEnd
.Execute


Wend


End With
Set rngStory = rngStory.NextStoryRange

Loop Until rngStory Is Nothing
Next
Application.ScreenUpdating = True
End Sub

[Doug Robbins]

Change


.Wrap = Word.WdFindWrap.wdFindStop

to


.Wrap = Word.wdFindStop

[bobby23]

Thank you for your answer Doug
I always thought these are the same things / properties
Anyway, changing doesn't help with the file I'm working with 10472
Hope I attached the file successfully
Maybe that will be helpful

[Doug Robbins]

Use


Sub Replacing()
Dim rngStory As Word.range
Application.ScreenUpdating = False
For Each rngStory In ActiveDocument.StoryRanges
Do
With rngStory.Find
.ClearFormatting
.Highlight = True
.Wrap = wdFindStop
.Execute
While .Found = True
If rngStory.HighlightColorIndex = wdRed Then
rngStory.Font.ColorIndex = wdRed
End If
rngStory.Collapse wdCollapseEnd
rngStory.Move wdCharacter, 1
.Execute
Wend
End With
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
Application.ScreenUpdating = True
End Sub

[bobby23]

Thank you Doug for your time
Your solution gets things done but at a cost... iterations are going through the roof with this solution
I tried similar one before, but working with a longer document was getting "time inefficient"
But thanks again for your time