Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Bestimmte Spalten untereinander kopieren

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
Anzeige
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
Anzeige
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.
Anzeige

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige