Dim rDataArea As Range
Set rDataArea = ActiveCell.CurrentRegion
Dim iTotalRows As Integer
iTotalRows = rDataArea.Rows.Count
Dim i As Integer
i = 3 'set to row you wish to start with..looked like row 3 from your post
Cells(i, 2).Select '2 is the column, B
Do Until ActiveCell.Row >= iTotalRows Or i >= iTotalRows
If ActiveCell.Text = "" Then
Selection.Delete Shift:=xlUp
i = i + 1
Else
ActiveCell.Offset(1, 0).Select
End If
Loop