Sub DeleteEmptyParagraphs()
Dim oRng As Range
Dim lngST As Long, lngCount As Long, lngIndex As Long
Dim oPar As Paragraph
  lngST = Timer
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Text = Chr(13) & "{2,}"
    .MatchWildcards = True
    While .Execute
      For lngIndex = oRng.Paragraphs.Count To 1 Step -1
        Set oPar = oRng.Paragraphs(lngIndex)
        If Len(oPar.Range.Text) = 1 Then
          oPar.Range.Select
          Select Case AscW(oPar.Range.Characters.Last.Next)
            Case 12 'Do nothing
            Case Else
              oPar.Range.Delete
              lngCount = lngCount + 1
          End Select
        End If
      Next lngIndex
      oRng.Collapse wdCollapseEnd
    Wend
  End With
  MsgBox "Paragraphs deleted: " & lngCount & "  |  Execution time: " & _
              Round(Timer - lngST, 2) & " s  |  " & Format((Timer - lngST) / 60, "0.00") & " min"
lbl_Exit:
  Exit Sub
End Sub