|
Laaaaaaaangsam, jetzt wird es erst richtig was - ;-)
LG
Sub KetteNach()
Dim ShS As Excel.Worksheet 'Quelle
Dim ShT As Excel.Worksheet 'Ziel - Arbeitsblatt
Dim rng, x, z, flag
Dim arr(), ary(), az
Application.ScreenUpdating = False
Set ShS = ThisWorkbook.Sheets("Tabelle1") 'einsetzen wo
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
|