Zeilen mehrfach woandershin kopieren

[PeterN]

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.

[Frogger1986]

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??

[PeterN]

  clever-excel-forum-de-thread-18007-Zeilen mehrfach woandershin kopieren-BEISPIEL.xlsx (Größe: 9,57 KB / Downloads: 5)

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.

[Frogger1986]

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??

[PeterN]

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.

[Frogger1986]

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!

[PeterN]

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

[Frogger1986]

wenn du dich im Bereich VBA etwas weiterbilden möchtest kann ich dir diesen: https://www.youtube.com/channel/UCsECQhL...pOiuQ9rE7g Videokanal auf YouTube empfehlen! 

im Anhang findest du die fertige Datei mit Button!

[PeterN]

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

[Frogger1986]

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