Hallo,
Bin auf der Suche nach einem VBA Makro welches in einer Excel Tabelle anhand des Wertes in Spalte „G“ die Zeile kopiert und direkt darunter einfügt ohne die nachfolgenden Zeilen zu überschreiben.
Beispiel:
In Spalte „G“ steht „1“ = nichts kopieren
In Spalte „G“ steht „2“ = Zeile 1x kopieren und darunter einfügen
In Spalte „G“ steht „3“ = Zeile 2x kopieren und darunter einfügen
usw…
Probiers mal damit:
Sub ZeilenKopierenEinfuegen()
Dim s As Long
Dim r As Long
s = 7
r = 1
Do While Not IsEmpty(Cells(r, s))
Select Case Cells(r, s)
Case 2
Rows®.Copy
Rows(r + 1).Insert
r = r + 2
Case 3
Rows®.Copy
Rows(r + 1).Insert
Rows®.Copy
Rows(r + 2).Insert
r = r + 3
Case Else
r = r + 1
End Select
Loop
Application.CutCopyMode = False
End Sub
Hallo
Vielen Dank für Dein Feedback mit dem VBA Code.
Irgendwo scheint jedoch ein Fehler zu sein. Wenn in Spalte G eine „2“ steht wird die Zeile 1x kopiert = richtig! Steht jedoch eine andere Zahl dort geschieht nichts.
Richtig! So soll es auch sein bei der 2 1x bei der3 2x kopieren. Oder möchtest du es flexibler?
Die Zahl in spalte G minus 1 = Anzahl der Kopien?
Kannst mich auch direkt anmailen:
[email protected]
lg
Hubert
Hallo Hubert
Genau, es sollte dynamisch sein, je nach Wert in Spalte G. Wenn dort z.B. 10 steht sollte die Zeile 9x kopiert werden, wenn 5 steht 4x, bei 50 49x usw…
Habe versucht deinen Code zu verstehen… sehe jedoch den Bezug auf Spalte G, resp. 7 nicht 
.
Vielen Dank, dass du mir hier weiterhilfst. Steht echt vor einem Problem.
Lg
Michael
Hallo G ist die 7. Spalte , zähl mal nach
Achtung das Script stoppt bei der ersten leeren Zelle in Spalte 7.
Versuch das:
Sub ZeilenKopierenEinfuegen()
Dim s As Long
Dim r As Long
Dim copies As Integer
s = 7 '= Spalte G Spaltenzeiger
r = 1 'Zeilenzeiger
Do While Not IsEmpty(Cells(r, s))
copies = Int(Cells(r, s) - 1)
For i = 1 To copies
Rows®.Copy
Rows(r + 1).Insert
Next
Select Case Cells(r, s)
'Zeilenzeiger hochsetzen je nach anzahl der Kopien, die sollen ja nicht auch gleich wieder kopiert werden
Case 1, 0 'keine Kopie also um 1 erhöhen
r = r + 1
Case Else
r = r + copies + 1 'Kopien also um 1+ anzahl Kopien erhöhen
End Select
Loop
Application.CutCopyMode = False
End Sub
So ist besser: es werden gemeldet wenn eine leere Zelle auftritt oder es keine Zahl ist:
Sub ZeilenKopierenEinfuegen()
Dim s As Long
Dim r As Long
Dim copies As Integer
s = 7 '= Spalte G
r = 1
Do While Not IsEmpty(Cells(r, s))
If IsNumeric(Cells(r, s)) = False Then
MsgBox "Zelle " & Cells(r, s).Address & „ist Leer oder enthält keine Zahl!“
Exit Sub
End If
copies = Int(Cells(r, s) - 1)
For i = 1 To copies
Rows®.Copy
Rows(r + 1).Insert
Next
Select Case Cells(r, s)
Case 1, 0
r = r + 1
Case Else
r = r + copies + 1
End Select
Loop
Application.CutCopyMode = False
End Sub
Hallo Hubert
Auf Zeile „copies = Int(Cells(r, s) - 1)“ bekomme ich einen Run-time error ‚13‘; Type missmatch.
Woran kann das liegen?
Falscxher Datentyp! Schick mir mal die Datei auf meine Mail. So kann ich das nicht sagen. Sonst würde ich als Hellseher auftreten!
lg
Hubert
Hallo Hubert
Es funktioniert nun alles. Vielen Dank für Deine grosse Hilfe!
LG
Michael