Sub CleanUpBlankLines() 

' Finds paragraph marks and spaces between broken paragraphs and removes them
' Finds empty paragraphs preceding numerals and removes them, too

    Application.ScreenUpdating = False
    
    Dim oRange As Range
         
    Set oRange = ActiveDocument.Range

    With oRange.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWildcards = True
        
        ' Remove gaps in text:
        .Text = "([!0-9] )([^13 ]{1,})([!0-9])"
        .Replacement.Text = "\1\3"
        .Execute Replace:=wdReplaceAll
        
        ' Remove spaces between empty paragraphs, in preparation
        ' to remove paragraphs preceding numbers:
        .Text = "(^13)( {1,})(^13)"
        .Replacement.Text = "\1\3"
        .Execute Replace:=wdReplaceAll
        
        ' Remove empty paragraphs preceding numbers:
        .Text = "([^13]{2,})([0-9])"
        .Replacement.Text = "^13\2"
        .Execute Replace:=wdReplaceAll
    
    End With
    
    With oRange.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWildcards = False
    End With
    
     Set oRange = Nothing

     Application.ScreenUpdating = True

 End Sub