Bestimmte Spalten untereinander kopieren

Hallo,
kann mir vielleicht jemand helfen wie kann ich aus diesem Makro eine Schleife machen? Wenn ich in diesem Fall 100 "y" Variablen habe, dann wird es nicht mehr lustig den Code copypasten
Im Prinzip geht es um Folgendes:
es gibt eine Tabelle:
Spalten D und E -Kundendaten, Spalten F bis J Produktdaten Produkt A, Spalten K bis O Produktdaten Produkt B usw...
Ich brauche alle Produktdaten untereinander. Spalten D und E (Kundendaten) sollen dann sich selber so viel mal nach unten kopieren, wie viele Produkte es gibt...
Sub Daten_bearbeiten()
Worksheets("Kontingente_csv").Range("A2:NX350000").Clear
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim QWS As Worksheet, ZWS As Worksheet
Set QWS = Worksheets("Daten")
Set ZWS = Worksheets("Kontingente_csv")
Dim x, y, y1, y2, y3, y4, y5, y6, y7, y8, y9, y20, y21, y22, y23, y24, y25, y26, y27, y28, y29, y30 As Long
x = IIf(IsEmpty(QWS.Range("A350000")), QWS.Range("A350000").End(xlUp).Row, 350000)
y = IIf(IsEmpty(ZWS.Range("A350000")), ZWS.Range("A350000").End(xlUp).Row, 350000)
QWS.Range("D6:J" & x).Copy
ZWS.Cells(2, 1).PasteSpecial xlPasteValues
y1 = IIf(IsEmpty(ZWS.Range("A350000")), ZWS.Range("A350000").End(xlUp).Row, 350000)
QWS.Range("D6:E" & x).Copy
ZWS.Cells(y1 + 1, 1).PasteSpecial xlPasteValues
QWS.Range("K6:O" & x).Copy
ZWS.Cells(y1 + 1, 3).PasteSpecial xlPasteValues
y2 = IIf(IsEmpty(ZWS.Range("A350000")), ZWS.Range("A350000").End(xlUp).Row, 350000)
QWS.Range("D6:E" & x).Copy
ZWS.Cells(y2 + 1, 1).PasteSpecial xlPasteValues
QWS.Range("P6:T" & x).Copy
ZWS.Cells(y2 + 1, 3).PasteSpecial xlPasteValues
y3 = IIf(IsEmpty(ZWS.Range("A350000")), ZWS.Range("A350000").End(xlUp).Row, 350000)
QWS.Range("D6:E" & x).Copy
ZWS.Cells(y3 + 1, 1).PasteSpecial xlPasteValues
QWS.Range("U6:Y" & x).Copy
ZWS.Cells(y3 + 1, 3).PasteSpecial xlPasteValues
y4 = IIf(IsEmpty(ZWS.Range("A350000")), ZWS.Range("A350000").End(xlUp).Row, 350000)
QWS.Range("D6:E" & x).Copy
ZWS.Cells(y4 + 1, 1).PasteSpecial xlPasteValues
QWS.Range("Z6:AD" & x).Copy
ZWS.Cells(y4 + 1, 3).PasteSpecial xlPasteValues
usw für y5, y6,...,y30.
Komme selber nicht weiter...
Danke
LG Lena

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim i As Integer Dim y As Integer Dim intLS As Integer Dim intLZ As Integer Dim Produkte As Integer With ActiveSheet intLZ = .Cells(Rows.Count, 4).End(xlUp).Row For i = intLZ To 2 Step -1 intLS = .Cells(i, Columns.Count).End(xlToLeft).Column Produkte = (intLS - 5) / 5 If Produkte >= 2 Then For y = 2 To Produkte .Rows(i + (y - 1)).EntireRow.Insert .Range(.Cells(i, (y * 5) + 1), .Cells(i, (y * 5) + 5)).Cut Destination:=.Range(. _ Cells(i + (y - 1), 6), .Cells(i + (y - 1), 10)) Application.CutCopyMode = False .Range(.Cells(i, 4), .Cells(i, 5)).Copy Destination:=.Range(.Cells(i + (y - 1), _ 4), .Cells(i + (y - 1), 5)) Application.CutCopyMode = False Next y End If Next i End With End Sub

Sub Test() Application.ScreenUpdating = False Application.EnableEvents = False Dim QWS As Worksheet, ZWS As Worksheet Set QWS = Worksheets("Daten") ' Quelle Set ZWS = Worksheets("Kontingente_csv") ' Ziel Dim x, i, y, a, As Long QWS.Range("D6:J" & x).Copy ZWS.Cells(2, 1).PasteSpecial xlPasteValues For a = 6 To 11 Step 5 y = IIf(IsEmpty(ZWS.Range("A350000")), ZWS.Range("A350000").End(xlUp).Row, 350000) QWS.Range("D6:E" & x).Copy ZWS.Cells(y + 1, 1).PasteSpecial xlPasteValues QWS.Range(Cells(6, a), Cells(x, a + 5)).Copy ZWS.Cells(y + 1, 3).PasteSpecial xlPasteValues Next a End Sub

Beliebteste Forumthreads (12 Monate)

Bestimmte Spalten untereinander kopieren

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bestimmte Spalten untereinander kopieren

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread