Loop through find and replace for line breaks - vba

Question

I'm trying to create a macro which finds a string and makes sure that there are always 3 line breaks after the string.
If Chapter One is found, there should always be 3 line breaks after it.
I need to loop through this until this is the case (so if there's 7 line breaks after "Chapter One" it needs to loop through until there are 3.
Unfortunately i'm having difficulty inserting the loop to remove more than 3 consecutive line breaks
Sub ChapterLineBreaks()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles( _
"Heading 1,Chapter Heading")
With Selection.Find
.Text = "Chapter One^p^p^p^p"
.Replacement.Text = "Chapter One^p^p^p"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Expected:
Chapter One
Text should then start here

Answer 1

You may need to use wildcards like this:
Sub ChapterLineBreaks()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles( _
"Heading 1,Chapter Heading")
With Selection.Find
.text = "(Chapter One)([^13]#)([!^13])"
.Replacement.text = "\1^p^p^p\3"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
You will find good info here, here, and here. What I did was use the wildcards to define a regular expression: "Chapter One{1 or more line breaks}Other text". I then replaced the line breaks with exactly 3 line breaks.