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