Search & Replace 3 carriage returns by 2 until no more exist

Burgos 0
Viewed 42

I am trying to remove all the occurences of more than 2 carriage returns until no more is found. The text can contain 4 consecutive carriage returns or more, so it can be 5, 8, 10...

I tried this macro copied from this site.

Sub Search3Return()
    Dim iCount As Integer
    Selection.HomeKey Unit:=wdStory
    
    With Selection.Find
        .ClearFormatting
        .Text = "^p^p^p"
        .Replacement.Text = "^p^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchFuzzy = False
        .MatchWildcards = False
        .Execute
    End With

    'If we find one then we can set off a loop to keep checking
    'put a counter in to avoid endless loops for one reason or another
    Do While Selection.Find.Found = True And iCount < 1000
        iCount = iCount + 1

        'Jump back to the start of the document.
        Selection.HomeKey Unit:=wdStory
        Selection.Find.Execute
    Loop
End Sub
vba ms-word
2 Answers

I don't know why you even bother with VBA for this - unless it's part of a larger VBA project. All you need is a single wildcard Find/Replace, where:

Find = ^13{3,}
Replace = ^p^p
macropod0

If you want the Find to not only find something but to replace it, you need to specify the Replace-parameter for the Execute-method, see https://learn.microsoft.com/en-us/office/vba/api/word.find

Sub Search3Return()
    Dim iCount As Integer
    Selection.HomeKey Unit:=wdStory
    
    With Selection.Find
        .ClearFormatting
        .Text = "^p^p^p"
        .Replacement.Text = "^p^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchFuzzy = False
        .MatchWildcards = False
        
        Do While iCount < 1000
            .Execute Replace:=wdReplaceAll
            If Not .Found Then Exit Do
            'Jump back to the start of the document.
            Selection.HomeKey Unit:=wdStory
            iCount = iCount + 1
        Loop
    End With

End Sub
FunThomas0
Related