Remove all empty paragraphs from a document

Article contributed by Dave Rado

You can remove most empty paragraphs from a document by doing a wildcard Find & Replace.

Replace: ^13{2,} with ^p, which (in theory – see below) replaces all occurrences of two or more consecutive paragraph marks with one paragraph mark. Or you can run the following macro, which does the same thing:

With Selection.Find
    .Text = "^13{2,}"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
End With

(Note that using Find and Replace is dramatically faster than cycling through the Paragraphs collection).

However, you can't use Find & Replace to delete the first or last paragraph in the document, if they are empty. To delete them you would need to add the following code to the above macro:

Dim MyRange As Range
Set MyRange = ActiveDocument.Paragraphs(1).Range
If MyRange.Text = vbCr Then MyRange.Delete

Set MyRange = ActiveDocument.Paragraphs.Last.Range
If MyRange.Text = vbCr Then MyRange.Delete

In addition, you can't use Find & Replace to delete the paragraph immediately preceding or following any tables, if these are empty. You would need to add the following code to the macro if you want them deleted – but be careful; if two tables are separated only by an empty paragraph, the following code will merge them into one table, which may or may not be the result you wanted:¹

Dim oTable As Table, MyRange As Range

For Each oTable In ActiveDocument.Tables
    #If VBA6 Then
        'The following is only compiled and run if Word 2000 or 2002 is in use
        'It speeds up the table and your code
        oTable.AllowAutoFit = False
    #End If

    'Set a range to the para following the current table
     Set MyRange = oTable.Range
    MyRange.Collapse wdCollapseEnd
    'if para after table empty, delete it
    If MyRange.Paragraphs(1).Range.Text = vbCr Then
        MyRange.Paragraphs(1).Range.Delete
    End If

     'Set a range to the para preceding the current table
    Set MyRange = oTable.Range
    MyRange.Collapse wdCollapseStart
    MyRange.Move wdParagraph, -1
     'if para before table empty, delete it
    If MyRange.Paragraphs(1).Range.Text = vbCr Then
        MyRange.Paragraphs(1).Range.Delete
    End If

Next oTable

You also can't use Find & Replace to delete the first or last paragraph in a table cell, if empty. If the user inserted an empty paragraph at the start or end of a table cell (in order to simulate “space before paragraph” or “space after paragraph”), you have to use something like the following to remove those empty paragraphs:

Dim oTable As Table, oCell As Cell, MyRange As Range
For Each oTable In ActiveDocument.Tables
    'Using oCell.Next to cycle through table cells is much quicker
    ' in long tables than using For Each oCell
    Set oCell = oTable.Range.Cells(1)
    For Counter = 1 To oTable.Range.Cells.Count

        If Len(oCell.Range.Text) > 2 And _
                oCell.Range.Characters(1).Text = vbCr Then
            'if cell is NOT blank, but it starts with a blank paragraph, delete the blank para
            'Note that a blank cell contains 2 characters; 
            'a paragraph mark and an end of cell marker
            oCell.Range.Characters(1).Delete
        End If

        If Len(oCell.Range.Text) > 2 And _
                Asc(Right$(oCell.Range.Text, 3)) = 13 Then
            'if cell is NOT blank, but it ends with a blank paragraph, delete the blank para
            Set MyRange = oCell.Range
            MyRange.MoveEnd Unit:=wdCharacter, Count:=-1
            MyRange.Characters.Last.Delete
        End If

        Set oCell = oCell.Next
    Next Counter

Next oTable

So the complete macro would look like this:

Sub DeleteEmptyParas()

Dim MyRange As Range, oTable As Table, oCell As Cell

With Selection.Find
    .Text = "^13{2,}"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
End With

Set MyRange = ActiveDocument.Paragraphs(1).Range
If MyRange.Text = vbCr Then MyRange.Delete

Set MyRange = ActiveDocument.Paragraphs.Last.Range
If MyRange.Text = vbCr Then MyRange.Delete

For Each oTable In ActiveDocument.Tables
    #If VBA6 Then
        'The following is only compiled and run if Word 2000 or 2002 is in use
         'It speeds up the table and your code
         oTable.AllowAutoFit = False
    #End If

    'Set a range to the para following the current table
     Set MyRange = oTable.Range
    MyRange.Collapse wdCollapseEnd
    'if para after table empty, delete it
    If MyRange.Paragraphs(1).Range.Text = vbCr Then
        MyRange.Paragraphs(1).Range.Delete
    End If

     'Set a range to the para preceding the current table
    Set MyRange = oTable.Range
    MyRange.Collapse wdCollapseStart
    MyRange.Move wdParagraph, -1
     'if para before table empty, delete it
    If MyRange.Paragraphs(1).Range.Text = vbCr Then
        MyRange.Paragraphs(1).Range.Delete
    End If

Next oTable

End Sub

__________________