Hola los todos!
Ich habe eine Liste mit ca. 8000 Zeilen und jeweils vier individuellen Werten (Zellen).
In der Spalte D steht jeweils eine Zahl, der höchste Wert ist 59 der kleinste Wert ist 2.
Gibt es eine Formel wo ich die jeweiligen Zeilen so oft untereinanderschreibe/kopiere wie der Wert in Spalte D lautet?
Also z.B. A1 B1 C1 59 erzeugt 59 x A1 B1 C1 oder:
A1 B1 C1
A1 B1 C1
A1 B1 C1
usw. bis 59x
und danach die Werte aus Zeile 2: A2 B2 C2 z.B. 58 x usw.
Zum Schluss habe ich dann ca. 40.000 Zeilen nach dem Wert in Spalte D gewichtet.
1.Eine Formel kann nichts kopieren, ausschneiden, verschieben...… Eine Formel kann nur etwas Berechnen und ausgeben!
2.Ja das geht mit VBA problemlos jedoch wäre hier deine Bsp. Datei von Vorteil!
3.Soll das einmalig passieren oder soll das öfters auf den gleichen Bereich angewendet werden??
[
attachment=20738]
Anbei eine Beispieldatei.
Vielen Dank!
Zu 3.) Die ersten drei Werte pro Zeile bzw. die Gesamtmenge der Zeilen bleibt immer gleich nur die Werte in Spalte D können sich verändern = erhöhen oder verringern.
D.h. Das Makro läuft öfters über den Bereich und soll erkennen, wenn bereits einmal etwas vermehrt wurde?? Wird der obere Beriech mit den Ausgansadressen erweitert, oder sind das alle die dort jemals stehen werden??
Die Basisliste bleibt immer gleich, nur die Zahlen in Spalte D würde ich manuell ändern und anschließend das Makro manuell drüberlaufen lassen.
Hier das Makro zum vermehren..
Code:
Option Explicit
Sub vermeheren()
Dim Last As Integer
Dim i As Integer
Dim c As Integer
Dim count As Integer
Last = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row
Range("A14:D" & Last).Clear
For i = 1 To 12
For c = 1 To CInt(Cells(i, 4).Value)
Last = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row + 1
If Last = 13 Then Last = 14 Else Last = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row + 1
Range(Cells(i, 1), Cells(i, 4)).Copy Range(Cells(Last, 1), Cells(Last, 4))
Cells(i, 1).Select
Next
Next
End Sub
Option Explicit
In ein Modul kopieren und dann auf einen Button im Tabellenblatt mit den Daten legen!
P.s. das Selektieren im oberen Bereich war Absicht, um eine Statusrückmeldung für dich zu implementieren!
Super! Danke!
Auch auf die Gefahr hin, das ich heute hier zum zweiten Mal darauf hingewiesen werde, das ich das mit dem Makro, Modul, der Schaltfläche oder was auch immer alleine hinkriege und bei G**gle steht wie es geht.
Ich kriege es einfach nicht hin.
Ich habe es heute vor mittag bei einem anderen Code hier im Forum schon mehrfach versucht.
Würdest Du mir das Ganze mit Makro, Modul, Schaltfläche oder was auch immer ich benötige schicken?
Vielen, lieben Dank
Moin Frogger!
Herzlichen Dank für die Datei!
Ich bekomme bei Zeile 834 bzw. 24.000 daraus generierten Zeilen immer den "Laufzeitfehler 6 Überlauf".
Ich habe hier im Forum schon geschaut und es mit .CountLarge probiert, aber der Fehler tritt immer noch auf.
Anbei mein modifizierter Code:
Sub vermeheren()
Dim Last As Integer
Dim i As Integer
Dim c As Integer
Dim count As Integer
Last = ActiveSheet.Cells(Rows.CountLarge, 1).End(xlUp).Row
Range("A7828:D" & Last).Clear
For i = 1 To 7829
Cells(i, 1).Select
For c = 1 To CInt(Cells(i, 4).Value)
Last = ActiveSheet.Cells(Rows.CountLarge, 1).End(xlUp).Row + 1
If Last = 7828 Then Last = 7829 Else Last = ActiveSheet.Cells(Rows.CountLarge, 1).End(xlUp).Row + 1
Range(Cells(i, 1), Cells(i, 4)).Copy Range(Cells(Last, 1), Cells(Last, 4))
Next
Next
MsgBox "Fertig!"
End Sub
Code:
Range("A7828:D" & Last).Clear
Das ist denke ich mehr als falsch.. Der Codesatz löscht die Werte von Zelle A7828 bis zur letzten Zeile in D !
wo ist denn deine letzte Zeile??
Code:
For i = 1 To 7829
If Last = 7828 Then Last = 7829 Else Last = ActiveSheet.Cells(Rows.CountLarge, 1).End(xlUp).Row + 1
Das ist auch sehr falsch weil das weit über den Oberen Bereich hinaus schießt! ( das dürfen nur die Stammdaten sein die du kopieren möchtest! )
du solltest dich vielleicht etwas einlesen in VBA....
versuche diesen Code
Code:
Option Explicit
Sub vermeheren()
Dim Last As Long
Dim i As Long
Dim c As Long
Dim count As Long
Last = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row
Range("A14:D" & Last).Clear
For i = 1 To 12
Cells(i, 1).Select
For c = 1 To CInt(Cells(i, 4).Value)
Last = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row + 1
If Last = 13 Then Last = 14 Else Last = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row + 1
Range(Cells(i, 1), Cells(i, 4)).Copy Range(Cells(Last, 1), Cells(Last, 4))
Next
Next
MsgBox "Fertig!"
End Sub