Search for "^p^p" and replace with "^p" loop this until it no find any one more "^p^p" in the active document.

I have this code:

(it's not working, its resulting in freeze/loop/crash word)

Dim oRng As Range

Set oRng = ActiveDocument.Range



With oRng.Find

.Wrap = wdFindStop

Do While .Execute(FindText:="^p^p",replacewith:="^p")

Loop

End With