Zeilen Abstand

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub ErstelleListe() Dim rng As Range, i As Integer i = 1 With Sheets("Tabelle1") For Each rng In .Range("A1:A" & .Range("A1").CurrentRegion.Rows.Count) Sheets("Tabelle2").Cells(i, 1) = rng i = i + rng.Offset(0, 1) + 1 Next End With End Sub

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, Rmax&, a, b, i&, j& Application.ScreenUpdating = False With WsQ Set r = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp)) With r Rmax = .Rows.Count + _ WorksheetFunction.Sum(.Offset(, 1).Resize(.Rows.Count, 1)) End With a = r: j = 1 ReDim b(1 To Rmax) For i = LBound(a) To UBound(a) 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: Erase a: Erase b End Sub

Option Explicit Sub a() Dim Wb As Workbook: Set Wb = ThisWorkbook Dim WsQ As Worksheet: Set WsQ = Wb.Worksheets("Tabelle2") Dim WsZ As Worksheet: Set WsZ = Wb.Worksheets("Tabelle6") Dim r As Range, Rmax&, a, b, i&, j& Application.ScreenUpdating = False With WsQ Set r = .Range(.Cells(2, 3), .Cells(.Rows.Count, 16).End(xlUp)) With r Rmax = .Rows.Count + _ WorksheetFunction.Sum(.Offset(, 1).Resize(.Rows.Count, 1)) End With a = r: j = 1 ReDim b(1 To Rmax) For i = LBound(a) To UBound(a) b(j) = a(i, 1) j = j + a(i, 2) + 1 Next i End With With WsZ .Range(.Cells(2, 1), .Cells(UBound(b), 1)) = Application.Transpose(b) 'die erste Zahl _ ind er Zeile bestimmt die Reihe des Resultats End With Set Wb = Nothing: Set WsQ = Nothing: Set WsZ = Nothing Set r = Nothing: Erase a: Erase b End Sub

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

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread