This is the best that I can do for getting rid of blank rows. It's a little bit slow, and alternatively I would like to move all the text upward into any empty spaces without deleting rows. Any ideas? 


Range("A2401").Select
For i = 1 To 2400
ActiveCell.Offset(-1, 0).Select
If ActiveCell.Value = Empty Then
ActiveCell.EntireRow.Delete
End If
Next i