VBA Zeile kopieren und darunter mehrfach einfügen

[MiBi]

Hallo Community,

ich habe ein Problem mit einer Excel Liste, welches ich mit VBA beheben möchte. Es geht darum, dass Zeilen, indem der Faktor "2" steht, kopiert werden sollen und genau darunter eingefügt werden sollen. Bei Zeilen mit dem Faktor "3", soll die Zeile kopiert werden und 2x drunter eingefügt werden. So z.B.:

222222
222222

33333333
33333333
33333333

44444444
44444444
44444444
44444444

Bisher habe ich es nur geschafft, unter der Zeile indem eine "2" steht, eine leere Zeile hinzuzufügen.

Code:

Dim u     As Integer


For u = 30000 To 1 Step -1
  If Cells(u, "L").Value = "2" Then
     Cells(u + 1, "L").EntireRow.Insert
     
  End If
Next u

Wie kann ich die ganze Zeile kopieren und drunter einfügen ? Bzw. bei anderen Werten mehrere Zeilen einfügen ?
Wäre für Hilfe sehr dankbar.

Viele Grüße

MiBi

[Lutz Fricke]

Hallo MiBi,

versuch doch mal das:

Code:

For u = 30000 To 1 Step -1
  If Cells(u, "L").Value >= 2 Then
    For Zaehler = 1 To Cells(u, "L").Value - 1
        Cells(u, "L").EntireRow.Copy
        Cells(u + 1, "L").Insert Shift:=xlDown
     Next Zaehler
  End If
Next u

Ist ungestestet.

Gruß,
Lutz

[Kuwer]

Hallo MiBi,

mein (getesteter) Vorschlag:

Sub aaa()
  Dim lngZ As Long
  Dim strE As String

  For lngZ = 30000 To 1 Step -1
    strE = Left(Cells(lngZ, "L").Value, 1)
    If IsNumeric(strE) Then
      Rows(lngZ).Copy
      Rows(lngZ + 1).Resize(CLng(strE) - 1).Insert
    End If
  Next lngZ
  Application.CutCopyMode = False
End Sub

Gruß Uwe

[MiBi]

Hallo MiBi,

versuch doch mal das:

Code:

For u = 30000 To 1 Step -1
  If Cells(u, "L").Value >= 2 Then
    For Zaehler = 1 To Cells(u, "L").Value - 1
        Cells(u, "L").EntireRow.Copy
        Cells(u + 1, "L").Insert Shift:=xlDown
     Next Zaehler
  End If
Next u

Ist ungestestet.

Gruß,
Lutz

Hallo Lutz,

vielen Dank für die Antwort. Leider funktioniert es damit nicht. Die Zeile mit x1Down passt laut VB nicht.

---

Hallo MiBi,

mein (getesteter) Vorschlag:

Sub aaa()
  Dim lngZ As Long
  Dim strE As String

  For lngZ = 30000 To 1 Step -1
    strE = Left(Cells(lngZ, "L").Value, 1)
    If IsNumeric(strE) Then
      Rows(lngZ).Copy
      Rows(lngZ + 1).Resize(CLng(strE) - 1).Insert
    End If
  Next lngZ
  Application.CutCopyMode = False
End Sub

Gruß Uwe

Hallo Uwe,

danke für die Hilfe. Auch hier klappt es leider irgendwie bei mir nicht. 
Die Zeile:  Rows(lngZ + 1).Resize(CLng(strE) - 1).Insert macht bei mir einen Fehler. 

[Kuwer]

Hallo,

vermutlich sind verbundene Zellen im Spiel, wenn diese Fehlermeldung kommt.

Gruß Uwe

[MiBi]

Hallo,

vermutlich sind verbundene Zellen im Spiel, wenn diese Fehlermeldung kommt.

Gruß Uwe

Hallo Uwe,

es ist eine Tabelle mit knapp 30000 Zeilen, wo in Spalte L entweder eine 1,2,3 oder 4 ist. Ich habe deinen Code mal woanders benutzt, leider klappt er da auch nicht. Ist es nicht einfach möglich, dass er bei meinem Code die Zeile kopiert und drunter einfügt, statt drunter eine leere Zeile zu erstellen ?

Code:

Dim u     As Integer


For u = 30000 To 1 Step -1
  If Cells(u, "L").Value = "2" Then
     Cells(u + 1, "L").EntireRow.Insert
     
  End If
Next u

Das hier klappt gut, jedoch kopiert er nicht die Zeile sondern fügt eine leere drunter ein. Mit "Copy" komm ich grad nicht zu recht.

[Lutz Fricke]

Hallo MiBi,

jetzt getestet:

Code:

For u = 30000 To 1 Step -1
  If Cells(u, "L").Value >= 2 Then
    For Zaehler = 1 To Cells(u, "L").Value - 1
        Cells(u, "L").EntireRow.Copy
        Cells(u + 1, "A").Insert Shift:=xlDown
     Next Zaehler
  End If
Next u

Gruß,
Lutz

[Kuwer]

Ich habe deinen Code mal woanders benutzt, leider klappt er da auch nicht.

Nun auch mit Einsern:

Sub aaa()
  Dim lngZ As Long
  Dim strE As String

  For lngZ = 30000 To 1 Step -1
    strE = Left(Cells(lngZ, "L").Value, 1)
    If IsNumeric(strE) Then
      If CLng(strE) > 1 Then
        Rows(lngZ).Copy
        Rows(lngZ + 1).Resize(CLng(strE) - 1).Insert
      End If
    End If
  Next lngZ
  Application.CutCopyMode = False
End Sub

Gruß Uwe

[MiBi]

Nun auch mit Einsern:

Sub aaa()
  Dim lngZ As Long
  Dim strE As String

  For lngZ = 30000 To 1 Step -1
    strE = Left(Cells(lngZ, "L").Value, 1)
    If IsNumeric(strE) Then
      If CLng(strE) > 1 Then
        Rows(lngZ).Copy
        Rows(lngZ + 1).Resize(CLng(strE) - 1).Insert
      End If
    End If
  Next lngZ
  Application.CutCopyMode = False
End Sub

Gruß Uwe

Danke Uwe :)
Klappt jetzt alles. Vielen vielen Dank

[VBA4Beginner]

Ich konnte die VBA-Lösung perfekt für mich einsetzen Und es hat mir unglaublich viel Arbeit erspart - herzlichen Dank dafür!
Einzig hätte ich den Unterschied, dass nicht die Inhalte der ganzen Zeilen kopiert werden sollen, sondern nur die Inhalte der ersten zwei Spalten.
Da auch ich VBA-technisch nicht wirklich fit bin, wäre ich für einen Tipp sehr dankbar.

Vielen Dank für jeden Tipp und ebensolche Grüße
VBA4Beginner