VBA WORD: Remove double paragraph marks

Question

Trying to move excessive paragraph gaps via this procedure.

Sub RemoveGaps()
    wrdDoc.Content.Select

    Selection.Find.ClearFormatting
    Selection.Find         


        

Answer 1

You don't need to fire whole sub but go back few lines like this:

Sub RemoveGaps()
Dim wrdDoc As Document
Set wrdDoc = ActiveDocument
    wrdDoc.Content.Select

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting

    With Selection.Find
        'oryginal
        .Text = "^13^13"
        .Replacement.Text = "^p"
        .Forward = True

    End With

GoHere:
    Selection.Find.Execute Replace:=wdReplaceAll

    If Selection.Find.Execute = True Then
        GoTo GoHere
    End If

End Sub

I tested it and it works fine with my Word 2010.

Answer 2

Sub RemoveGaps()

    Dim oFnd As Find

    Set oFnd = ThisDocument.Content.Find
    oFnd.ClearFormatting
    oFnd.Replacement.ClearFormatting

    With oFnd
        .Text = "^13^13"
        .Replacement.Text = "^p"

        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = True
    End With

    Do
        oFnd.Execute Replace:=wdReplaceAll
    Loop Until Not oFnd.Execute Or oFnd.Parent.End = ThisDocument.Content.End

End Sub

I have no idea why KazJaw's works - it still leaves two paragraph marks at the end, but Execute returns False. When I get to the last GoTo, I get this in the Immediate Window.

?selection.Find.Execute
False
?selection = string(2,chr$(13))
True

Why doesn't it find two carriage returns when that's all it is? Odd. Anyway, I don't like changing the selection or GoTo so I included my version. It quits when Find can't find anything or when it's at the end of the Document.

If you know the upper limit of how many paragraphs there will be in a row, you could do it a different way. For instance, if you know there are no more than 10 blank paragraphs, you could do this:

Sub RemoveGaps2()

    Dim i As Long

    For i = 10 To 2 Step -1
        With ThisDocument.Content.Find
            .Text = "[^13]{" & i & ",}"
            .Replacement.Text = Chr$(13)
            .MatchWildcards = True
            .Execute , , , , , , , , , , wdReplaceAll
        End With
    Next i

End Sub

Answer 3

Try this

Sub RemoveGaps()
    wrdDoc.Content.Select

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting

    With Selection.Find
        .Text = "^p^p" '<~~~ See this
        .Replacement.Text = "^p"

        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False '<~~ Set this to false
    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    If Selection.Find.Execute = True Then
        Call RemoveGaps
    End If
End Sub