Zeile kopieren und runterzählen

Forumthread: Zeile kopieren und runterzählen

23.09.2020 09:54:39

Simon

Hallo Zusammen
Ich suche eine Lösung für folgende Aufgabe:
Ausgangslage:
Excel mit vier Spalten und einer varaiblen Anzahl Zeilen.
In der Spalte B ist eine Mengenanbagen, in den Spalten A, C und D sind Informationen als Zahlen oder Buchstaben.
Ziel:
Ist die Mengeangabe der Zelle in der Spalte B grösser 1, so soll die Zeile kopiert und unten an die Tabelle angeführt werden. Dabei soll in der neuen Zeile den Spaltenwert B die Menge 1 haben und bei der Ausgangszeile soll der Zellenwert der Spalte B um 1 veringert werden.
Dies soll wieder holt werden, bis die Ausgangszeile der Zellenwert in Spalte B = 1 ist, anschliessend zur nächsten Zeile weiter und das Ganze wiederholen.
Beispiel:
Ausgangswerte:

	Spalte A	Spalte B	Spalte C	Spalte D
Zeile 1	6203N	4	Inventar	Info
Zeile 2	5777N	2	16762	Info
Zeile 3	5777R	1	16801	Info
Zeile 4	8504R	3	16810	Info

Zielwerte:

	Spalte A	Spalte B	Spalte C	Spalte D
Zeile 1	6203N	1	Inventar	Info
Zeile 2	5777N	1	16762	Info
Zeile 3	5777R	1	16801	Info
Zeile 4	8504R	1	16810	Info
Zeile 5	6203N	1	Inventar	Info
Zeile 6	6203N	1	Inventar	Info
Zeile 7	6203N	1	Inventar	Info
Zeile 8	5777N	1	16762	Info
Zeile 9	8504R	1	16810	Info
Zeile 10	8504R	1	16810	Info

Ich hoffe die Problemstellung verständlich notiert zu haben und bin euch für eure VBA-Lösungen bereits jetzt unheimlich dankbar.
Liebe Grüsse
Simon

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Zeile kopieren und runterzählen

23.09.2020 10:16:27

Rudi
AW: Zeile kopieren und runterzählen

24.09.2020 10:55:38

Simon
AW: Zeile kopieren und runterzählen

23.09.2020 10:18:09

Reinhold

AW: Zeile kopieren und runterzählen

23.09.2020 10:16:27

Rudi

Hallo,

Sub aaa()
Dim arrOUT(), arrIn
Dim lngIndex As Long, i As Integer, n As Long
ReDim arrOUT(1 To WorksheetFunction.Sum(Columns(2)), 1 To 4)
arrIn = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)).Resize(, 4)
For lngIndex = 1 To UBound(arrIn)
For i = 1 To arrIn(lngIndex, 2)
n = n + 1
arrOUT(n, 1) = arrIn(lngIndex, 1)
arrOUT(n, 2) = 1
arrOUT(n, 3) = arrIn(lngIndex, 3)
arrOUT(n, 4) = arrIn(lngIndex, 4)
Next i
Next lngIndex
Cells(1, 1).Resize(UBound(arrOUT), 4) = arrOUT
End Sub

Gruß
Rudi

AW: Zeile kopieren und runterzählen

24.09.2020 10:55:38

Simon

Vielen herzlichen Dank!
Das hat mir bereits sehr geholfen. :-)
Grüsse
Simon

AW: Zeile kopieren und runterzählen

23.09.2020 10:18:09

Reinhold

Do Until Cells(i,2) <> ""
lZeile=Cells(i,2).End(xlDown).Offset(1,0).Row
If Cells(i,2).Value>1 Then
Wert=Cells(i,2).Value
For Wert=Wert to 1 Step -1
Cells(lZeile,1).Value=Cells(i,1).Value
Cells(lZeile,2).Value=1
Cells(lZeile,3).Value=Cells(i,3).Value
Cells(lZeile,3).Value=Cells(i,4).Value
lZeile=lZeile+1
next
End if
Cells(i,2).Value=1
i=i+1
Loop
So in etwa?
Wenns natürlich wesentlich mehr Zeilen sind bzw. Spalten, dann würde ich gleich die ganze Zeile kopieren, bzw. mit Arrays arbeiten

Beliebteste Forumthreads (12 Monate)

Forumthread: Zeile kopieren und runterzählen

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread