Sorry, hab's jetzt soweit ergänzt, dass der komplette Tabellenbereich - um die Spalte mit dem Kettenende ergänzt - kopiert wird.
Das Problem mit den Kettenunterbrechungen besteht aber dennoch weiterhin.
Sub Tabelle2_Schaltfläche1_Klicken()
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("Rohdaten") '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(, 30)
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 30, 1 To az)
ary(30, az) = arr(x, 29)
ary(29, az) = arr(x, 28)
ary(28, az) = arr(x, 27)
ary(27, az) = arr(x, 26)
ary(26, az) = arr(x, 25)
ary(25, az) = arr(x, 24)
ary(24, az) = arr(x, 23)
ary(23, az) = arr(x, 22)
ary(22, az) = arr(x, 21)
ary(21, az) = arr(x, 20)
ary(20, az) = arr(x, 19)
ary(19, az) = arr(x, 18)
ary(18, az) = arr(x, 17)
ary(17, az) = arr(x, 16)
ary(16, az) = arr(x, 15)
ary(15, az) = arr(x, 14)
ary(14, az) = arr(x, 13)
ary(13, az) = arr(x, 12)
ary(12, az) = arr(x, 11)
ary(11, az) = arr(x, 10)
ary(10, az) = arr(x, 9)
ary(9, az) = arr(x, 8)
ary(8, az) = arr(x, 7)
ary(7, az) = arr(z, 7)
ary(6, az) = arr(x, 6)
ary(5, az) = arr(x, 5)
ary(4, az) = arr(x, 4)
ary(3, az) = arr(x, 3)
ary(2, az) = arr(x, 2)
ary(1, az) = arr(x, 1)
Else
az = az + 1
ReDim Preserve ary(1 To 30, 1 To az)
ary(30, az) = arr(x, 29)
ary(29, az) = arr(x, 28)
ary(28, az) = arr(x, 27)
ary(27, az) = arr(x, 26)
ary(26, az) = arr(x, 25)
ary(25, az) = arr(x, 24)
ary(24, az) = arr(x, 23)
ary(23, az) = arr(x, 22)
ary(22, az) = arr(x, 21)
ary(21, az) = arr(x, 20)
ary(20, az) = arr(x, 19)
ary(19, az) = arr(x, 18)
ary(18, az) = arr(x, 17)
ary(17, az) = arr(x, 16)
ary(16, az) = arr(x, 15)
ary(15, az) = arr(x, 14)
ary(14, az) = arr(x, 13)
ary(13, az) = arr(x, 12)
ary(12, az) = arr(x, 11)
ary(11, az) = arr(x, 10)
ary(10, az) = arr(x, 9)
ary(9, az) = arr(x, 8)
ary(8, az) = arr(x, 7)
ary(7, az) = arr(x, 7)
ary(6, az) = arr(x, 6)
ary(5, az) = arr(x, 5)
ary(4, az) = arr(x, 4)
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(7)) Then .Cells(7) = "Kettenbeginn"
If Not IsDate(.Cells(8)) Then .Cells(8) = "Kettenende"
End With
Application.ScreenUpdating = True
End Sub
|