[table="width: 500"]
[tr]
[td]Sub LeaveOneBlankRow()
Dim Ar As Range
With Range("A1", Cells(Rows.Count, "A").End(xlUp))
For Each Ar In .SpecialCells(xlBlanks).Areas
If Ar.Rows.Count > 1 Then Ar.Offset(1).Resize(Ar.Rows.Count - 1).EntireRow.Delete
Next
End With
End Sub[/td]
[/tr]
[/table]