Bestimmte Spalten untereinander kopieren

Forumthread: Bestimmte Spalten untereinander kopieren

18.02.2019 11:12:15

Len

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

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Bestimmte Spalten untereinander kopieren

18.02.2019 11:52:56

Bernd
AW: Bestimmte Spalten untereinander kopieren

18.02.2019 14:40:31

Len

AW: Bestimmte Spalten untereinander kopieren

18.02.2019 11:52:56

Bernd

Servus Len,
teste mal...


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

Grüße, Bernd

AW: Bestimmte Spalten untereinander kopieren

18.02.2019 14:40:31

Len

Hallo Bernd,
vielen Dank für deine schnelle Antwort, funktioniert leider nicht, bei 10000 Kunden bleibt alles hängen...
Ich habe hier noch sowas probiert:

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

Halbwegs macht er was ich will...
Danke dir.

Beliebteste Forumthreads (12 Monate)

Bestimmte Spalten untereinander kopieren

Forumthread: Bestimmte Spalten untereinander kopieren

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread