Ganze Zeilen in Sheet vervielfältigen

Hallo Spezialisten da draußen,

wie man vllt erahnen kann, habe ich ein Problem...
ich habe eine Tabelle indem mehrere Zeilen vorkommen. in der Tabelle sind auch Mengen angegeben (siehe Beispiel)

Jetzt ist es so, dass die Zeilen, die indem die Menge mehr als '1' ist, so oft kopiert werden soll, dass ich im So viele Zeilen habe, dass überall Menge '1' steht.

also im Endeffekt soll es so aussehen:

Die Tabelle ist natürlich stark vereinfacht. In den meisten Fällen ist es so, dass ich hunderte Datenasätze mit unzähligen Spalten habe. Ich müsste also irgendwie dynamisch sagen können, in welcher Spalte die Mengen stehen, auf die sich das Skript beziehen soll... (zB: die Spalte der aktiven Zelle, oder so) eine weitere Schwierigkeit ist zudem noch, dass er nach kopieren dann die werte auf 1 ändern soll.. oder evtl, mehrmalig durchgehen soll, und nach jedem kopieren und einfügen den wert herunterzählt und in der neu eingefügten Zelle den Wert '1' einträgt. Natürlich können auch Spaltenüberschriften vorhanden sein... alles sehr kopliziert.

ich habe zwar ein Skript mitdem ich einfach jede Zelle verdoppeln kann, aber das ist in diesem fall wohl eher unbrauchbar,.. aber trotzdem möchte ich euch es nicht vorenthalten:



ich hoffe ihr habt irgendeine idee, wie ich anfangen kann


Kurzfristig habe ich das mit einer Formel gelöst, diese ist auf dem zweiten Tabellenblatt.

elegeanter wäre es aber natürlich über ein Skript

mfg
Shitz

Sub zeilen_verdoppeln()
Const Spalte = "B"  

Dim lastrow As Long, i As Long, Anzahl As Long
Dim wks1 As Worksheet

Set wks1 = ActiveSheet
lastrow = wks1.Cells(Rows.Count, TheColumn).End(xlUp).Row  'durchgehend genutzte Spalte nutzen  

For i = lastrow To 1 Step -1
    Anzahl = Cells(i, Spalte).Value
    If Anzahl <> 1 Then
        Cells(i, Spalte).Value = 1
        For j = 1 To Anzahl - 1
            wks1.Rows(i + 1).Insert
            wks1.Rows(i).Copy wks1.Rows(i + 1)
        Next
    End If
Next i
End Sub

Sub zeilen_verdoppeln()

Dim Spalte          As String
Dim lastrow         As Long
Dim i               As Long
Dim Anzahl          As Variant
Dim wks1            As Worksheet
Application.EnableEvents = False


On Error GoTo Fehler
Spalte = ActiveCell.Column
Set wks1 = ActiveSheet
lastrow = wks1.Cells(Rows.Count, 1).End(xlUp).Row
For i = lastrow To 1 Step -1
    Anzahl = Cells(i, ActiveCell.Column).Value
    If IsNumeric(Anzahl) And Anzahl > 1 Then
            Cells(i, ActiveCell.Column).Value = 1
        For j = 1 To Anzahl - 1
            wks1.Rows(i + 1).Insert
            wks1.Rows(i).Copy wks1.Rows(i + 1)
        Next
    End If
Fehler:
Next i
End Sub