Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

VBA Zeile kopieren und darunter mehrfach einfügen
#1
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
Antwortento top
#2
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
Antwortento top
#3
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
Antwortento top
#4
(07.09.2020, 10:07)Lutz Fricke schrieb: 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.

(07.09.2020, 10:10)Kuwer schrieb: 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. 


Angehängte Dateien Thumbnail(s)
   
Antwortento top
#5
Hallo,

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

Gruß Uwe
Antwortento top
#6
(07.09.2020, 10:33)Kuwer schrieb: 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.
Antwortento top
#7
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
Antwortento top
#8
(07.09.2020, 10:40)MiBi schrieb: 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
Antwortento top
#9
(07.09.2020, 10:51)Kuwer schrieb: 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 UweSmile
Klappt jetzt alles. Vielen vielen Dank
Antwortento top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste