Sub
KetteNach()
Dim
ShS
As
Excel.Worksheet
Dim
ShT
As
Excel.Worksheet
Dim
rng, x, z, flag
Dim
arr(), ary(), az
Application.ScreenUpdating =
False
Set
ShS = ThisWorkbook.Sheets(
"Tabelle1"
)
Set
ShT = ThisWorkbook.Sheets(
"Tabelle3"
)
With
ShS
Set
rng = .UsedRange.Columns(1).Cells(1)
Set
rng = Range(rng, .Cells(.Rows.Count, rng.Column).
End
(xlUp).Offset(1)).Resize(, 4)
arr = rng.Value
End
With
For
x = LBound(arr, 1)
To
UBound(arr, 1) - 1
If
flag =
False
Then
z = x
If
arr(x, 1) = arr(x + 1, 1)
And
arr(x, 2) = arr(x + 1, 2)
Then
flag =
True
Else
If
flag =
True
Then
az = az + 1
ReDim
Preserve
ary(1
To
4, 1
To
az)
ary(4, az) = arr(x, 3)
ary(3, az) = arr(z, 3)
ary(2, az) = arr(x, 2)
ary(1, az) = arr(x, 1)
Else
az = az + 1
ReDim
Preserve
ary(1
To
4, 1
To
az)
ary(4, az) = arr(x, 3)
ary(3, az) = arr(x, 3)
ary(2, az) = arr(x, 2)
ary(1, az) = arr(x, 1)
End
If
flag =
False
End
If
Next
x
With
ShT
.Cells.Clear
.Cells(1).Resize(UBound(ary, 2), UBound(ary, 1)).Value = Application.Transpose(ary)
If
Not
IsDate(.Cells(3))
Then
.Cells(3) =
"Beginn"
If
Not
IsDate(.Cells(4))
Then
.Cells(4) =
"Ende"
End
With
Application.ScreenUpdating =
True
End
Sub