Sub Katte()
Dim rng, x, z, flag
Application.ScreenUpdating = False
With ActiveSheet
Set rng = .UsedRange.Columns(1).Cells(1)
Set rng = Range(rng, .Cells(.Rows.Count, rng.Column).End(xlUp).Offset(1)).Resize(, 4)
For x = 1 To rng.Rows.Count - 1
If flag = False Then z = x
If rng.Rows(x).Cells(1).Value = rng.Rows(x + 1).Cells(1).Value And _
rng.Rows(x).Cells(2).Value = rng.Rows(x + 1).Cells(2).Value Then
rng.Rows(x).Cells(4) = "*"
flag = True
Else
If flag = True Then
rng.Rows(x).Cells(4).Value = rng.Rows(x).Cells(3).Value
rng.Rows(x).Cells(3).Value = rng.Rows(z).Cells(3).Value
Else
rng.Rows(x).Cells(4).Value = rng.Rows(x).Cells(3).Value
End If
flag = False
End If
Next x
With .UsedRange
.AutoFilter
.AutoFilter Field:=4, Criteria1:="<>*", Operator:=xlAnd
For x = .Rows.Count To 1 Step -1
If .Rows(x).EntireRow.Hidden Then .Rows(x).EntireRow.Delete
Next x
End With
With .UsedRange
.AutoFilter
.Rows(1).Cells(3).Value = "Beginn"
.Rows(1).Cells(4).Value = "Ende"
End With
End With
Application.ScreenUpdating = True
End Sub