This is one way to do it. This will remove blank cells from every column on your sheet
Option Explicit
Public Sub RemoveBlanks()
Dim rng As Range
Dim c
Set rng = Application.InputBox("Select a range", "Get Range", Type:=8)
If Not rng Is Nothing Then
On Error Resume Next
With rng.Parent
For Each c In rng
Range(c, c.Offset(.Cells(.Rows.Count, c.Column).End(xlUp).Row - c.Row, 0)).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
Next c
End With
On Error GoTo 0
Else
MsgBox "Nothing selected"
End If
End Sub