Option Explicit
Sub Verschieben()
Dim rngCell As Excel.Range
Dim rngCellFirst As Excel.Range
Dim rngCellLast As Excel.Range
Set rngCellFirst = Range("A1")
Set rngCellLast = Cells(Rows.Count, rngCellFirst.Column).End(XlDirection.xlUp)
If rngCellLast.Row <= rngCellFirst.Row _
Then Exit Sub
Set rngCell = rngCellFirst
Do While rngCell.Row <= rngCellLast.Row
If rngCell.Value = "" Then
Set rngCell = rngCell.Offset(1)
If rngCell.Offset(-1).Address = rngCellFirst.Address Then
Set rngCellFirst = rngCell
End If
Call rngCell.Offset(-1).EntireRow.Delete(XlDeleteShiftDirection.xlShiftUp)
Else
Set rngCell = rngCell.Offset(1)
End If
Loop
With rngCellFirst.Worksheet
If Not ActiveSheet Is rngCellFirst.Worksheet Then
rngCellFirst.Worksheet.Activate
End If
.Range(rngCellFirst, rngCellLast).Select
End With
End Sub