Jim, try something like the following. This builds up the selection
with all the blank rows you wish to delete and deletes them all at
once.

Sub DeleteBlankRows()
Dim lastRow As Long
Dim firstRowFound As Boolean

firstRowFound = False

' last row with data in it on this sheet
lastRow = ActiveSheet.UsedRange.Rows.Count

For i = 1 To lastRow
' the condition on which to decide to delete this row
If IsEmpty(Range("B" & i)) Then
If firstRowFound = True Then
' first time finding a blank row, then select it...
Rows(i).Select
firstRowFound = False
Else
' ... otherwise add it to the selected rows
Union(Selection, Rows(i)).Select
End If
End If
Next i

' delete the selection
Selection.Delete shift:=xlShiftUp

' select only one cell
ActiveCell.Select
End Sub