Zeile entsprechend Wert öfter kopieren

[lowzino]

Hallo Leute,

ich habe in einem anderen Forum eine Fragestellung gefunden, die genau meinem Problem entspricht, bei mir aber nicht funktioniert. Hoffe ihr könnt mir hier weiterhelfen. Der einfachheit halber habe ich alles mal kopiert.

Und zwar habe ich eine Tabelle in der verschiedene Datensätze stehen.

Ungefähr so:

Spalte A (Artikel)/ Spalte B (Menge) / Spalte C (Bemerkung)/ Spalte D (Sonstiges)
Handschuhe / 5 / gepudert / OP2
Spritze / 3 / groß / OP1


Ich bräuchte nun für eine sinnvolle Datenbankstruktur die Auflistung am Ende so:

Spalte A (Artikel)/ Spalte B (Menge) / Spalte C (Bemerkung)/ Spalte D (Sonstiges)
Handschuhe / 1 / gepudert / OP2
Handschuhe / 1 / gepudert / OP2
Handschuhe / 1 / gepudert / OP2
Handschuhe / 1 / gepudert / OP2
Handschuhe / 1 / gepudert / OP2
Spritze / 1 / groß / OP1
Spritze / 1 / groß / OP1
Spritze / 1 / groß / OP1

Das heißt, ich bräuchte einen code der mir jede Zeile genau so oft nach unten kopiert, wie in der Mengenspalte in der entsprechenden Zeile steht.
Denn dann kann ich jedem Artikel, also jeder Zeile einen Patienten zuordnen.
--> Im Endeffekt benötige ich eine Schleife, die die Zeile so oft kopiert, wie in der Mengenspalte der aktuellen Zeile steht. Also für jeden Artikel eine eigene Zeile.

Hier der Code, der dem letzten geholfen hat und der Link zum selber nachschauen.

CODE:

Sub Erweitern()
Dim lRow As Long
Dim lCnt As Long, lCntTop As Long
Application.ScreenUpdating = False
With ActiveSheet
For lRow = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
If IsNumeric(.Cells(lRow, 2)) Then
lCntTop = .Cells(lRow, 2)
.Cells(lRow, 2) = 1
For lCnt = lCntTop To 2 Step -1
.Rows(lRow).Insert
.Rows(lRow + 1).Copy Destination:=Cells(lRow, 1)
Next lCnt
End If
Next lRow
End With
Application.ScreenUpdating = True
End Sub

http://www.office-loesung.de/ftopic357314_0_0_asc.php

 

[FranzvonAssisi]

Uund am besten lässt du die Menge gleich weg, wenn diese immer 1 ist, brauchst du dafür ja keine Spalte.

Lg

 

[Diddlfuß]

Ich habe mir den Code mal kopiert und ihn getestet - funktioniert einwandfrei! Was passiert denn bei Dir, wenn Du das Makro startest? Irgendeine Fehlermeldung oder einfach großes Schweigen?