Für unzusammenhängende Bereiche...
30.08.2017 10:01:30
Michael
Guggus,
...ist das leider etwas komplizierter, als nur die Spalten in der Bereichs-Definition anzupassen; so wie Du getan hast, definierst Du einen Zellbereich von C2:Px, inkl. aller dazwischenliegenden Zellen. Du willst aber nur die beiden isolierten Bereiche C2:Cx, P2:Px ins Array laden. Daher:
Ergänzte Bsp-Mappe: https://www.herber.de/bbs/user/115876.xlsm
Ergänzter Code:
Sub a()
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim WsQ As Worksheet: Set WsQ = Wb.Worksheets("Tabelle1")
Dim WsZ As Worksheet: Set WsZ = Wb.Worksheets("Tabelle2")
Dim r As Range, c As Range, Rmax&, a, b, i&, j&
Application.ScreenUpdating = False
With WsQ
Set r = .Range(.Cells(2, "C"), .Cells(.Rows.Count, "C").End(xlUp))
Rmax = r.Rows.Count + _
WorksheetFunction.Sum(r.Offset(, 13).Resize(r.Rows.Count, 1))
a = r: ReDim Preserve a(1 To UBound(a), 1 To 2)
For Each c In r.Offset(, 13).Resize(r.Rows.Count, 1)
i = i + 1: a(i, 2) = c
Next c
j = 1
ReDim b(1 To Rmax)
For i = LBound(a, 1) To UBound(a, 1)
b(j) = a(i, 1)
j = j + a(i, 2) + 1
Next i
End With
With WsZ
.Range(.Cells(1, 1), .Cells(UBound(b), 1)) = Application.Transpose(b)
End With
Set Wb = Nothing: Set WsQ = Nothing: Set WsZ = Nothing
Set r = Nothing: Set c = Nothing: Erase a: Erase b
End Sub
Passt?
LG
Michael