Zeilen x-mal kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Piet,
funktioniert super. In meiner Originaldatei stehen die Werte in Spalten 25 bis 30. Davor und danach gibt es auch noch Spalten, die kopiert werden sollten. Ich habe mal Teile des Code kopiert und markiert, wo aus meiner Sicht anpassungen erfolgen müssten:
Bei dem Schritt ist mir nicht klar, was er in Spalte 6 und 4 macht.

.Cells(AC.Row, 1).Resize(1, 6).Copy ZTab.Cells(z, 1)
'ganzen Datensatz auf "0" stellen
ZTab.Cells(z, 2).Resize(1, 4) = 0
Wenn sich die Werte in den Spalten 25 bis 30 befinden, muss ich j anpassen.
Das mit Tezise 6 ist mir nicht klar.
For j = 2 To 5
If .Cells(AC.Row, j) > 0 Then
'Nullzeile nach unten kopieren
ZTab.Cells(z, 1).Resize(1, 6).Copy ZTab.Cells(z + 1, 1)
ZTab.Cells(z, j).Value = .Cells(AC.Row, j).Value
z = z + 1
End If
Next j
Next AC
'Letzte Nullzeile löschen! (überflüssig)
ZTab.Cells(z, 1).Resize(1, 6).Clear

Hier habe die nochmal die Datei: https://www.herber.de/bbs/user/130871.xlsm
Grüße
Stephan

Hallo Stephan
anbei der korrigierte Code, jetzt sollte er wie gewünscht laufen. In Spalte Y-AD hab ich die Nullen gelöscht.
Wenn du lieber Nullen haben willst musst du nur hier Empty durch 0 ersetzen!
ZTab.Cells(z, 25).Resize(1, 5) = 0
mfg Piet

Sub Umsaetze_einzeln_auflisten()
Dim AC As Range, j As Integer
Dim QTab As Worksheet, z As Long
Dim ZTab As Worksheet, lz1 As Long
On Error GoTo Fehler
Set ZTab = Worksheets(ZielTab)
'alte Ziel Tabelle kompltt löschen
ZTab.Rows("2:" & Rows.Count).Delete
Application.ScreenUpdating = False
With Worksheets(Quelle)
'LastZell in Quell Tabelle suchen
lz1 = .Cells(Rows.Count, 1).End(xlUp).Row
z = 2  '1. Zeile in Ziel Tabelle
'alle Quell Daten einzeln kopieren
For Each AC In .Range("A2:A" & lz1)
'ganzen Datensatz mit Formel kopieren
.Cells(AC.Row, 1).Resize(1, 31).Copy ZTab.Cells(z, 1)
'** ganzen Datensatz auf "0" stellen oder löschen
ZTab.Cells(z, 25).Resize(1, 5) = Empty  '0
For j = 25 To 29
If .Cells(AC.Row, j) > 0 Then
'Nullzeile nach unten kopieren
ZTab.Cells(z, 1).Resize(1, 31).Copy ZTab.Cells(z + 1, 1)
ZTab.Cells(z, j).Value = .Cells(AC.Row, j).Value
z = z + 1
End If
Next j
Next AC
'Letzte Nullzeile löschen!  (überflüssig)
ZTab.Cells(z, 1).Resize(1, 31).Clear
End With
Exit Sub
Fehler:  MsgBox "Fehler aufgetreten:  " & Chr(10) & Error()
End Sub

For j = 25 To 29 If .Cells(AC.Row, j) > 0 Then 'Nullzeile nach unten kopieren ZTab.Cells(z, 1).Resize(1, 31).Copy ZTab.Cells(z + 1, 1) ZTab.Cells(z, j).Value = .Cells(AC.Row, j).Value ZTab.Cells(z, 30).Value = ZTab.Cells(z, 30).Value z = z + 1 End If Next j

Beliebteste Forumthreads (12 Monate)

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread