Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 12:58:59
Daten einfügen aus anderem Sheet
19.04.2024 12:23:24
Wenn-Formel anpassen
19.04.2024 12:09:19
Unique (Application.WorksheetFunction.Unique)
19.04.2024 11:51:37
Nächsten identischen Treffer suchen
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1808to1812
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1808to1812
1808to1812
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Zeilen kopieren auf Basis Anzahl

Zeilen kopieren auf Basis Anzahl
31.01.2021 12:47:55
Martin
Hallo liebes Forum,
ich bin gerade dabei eine Excel zu bearbeiten in der aus bestimmten Zeilen mehrere Zeilen gemacht werden müssen. Im Grunde klingt es ganz einfach. Wenn in Spalte I eine 1 steht dann passt alles, wenn dort eine 2 oder höher steht dann kopiere die Zeile je nach Anzahl also z.B. bei einer 2 einmal und füge in Spalte M in der Originalzeile den Hinweis 1 von 2 und in der kopierten Zeile den Hinweis 2 von 2 ein. In beiden Zeilen soll zudem dann in Spalte I statt der 2 eine 1 stehen. Das muss für alle Zeilen durchgegangen werden bis zum Ende. Bei 3 brauche ich insgesamt 3 Zeilen, bei 4 4 Zeilen usw.
Ich habe das mal per Makroaufzeichner gemacht und "per Hand" kommt folgendes raus:
1. Spalte I auswählen
2. Zum Beispiel nach 3 suchen
3. diese Zeile dann 2x kopieren
4. In Spalte M die Hinweise hinzufügen
5. In Spalte I in den 3 Zeilen statt 3 eine 1 hinschreiben

Sub Makro1()
Columns("I:I").Select
Selection.Find(What:="3", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Rows("16:16").Select
Selection.Copy
Rows("17:17").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
Selection.Insert Shift:=xlDown
Range("I16").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "1"
Range("I17").Select
ActiveCell.FormulaR1C1 = "1"
Range("I18").Select
ActiveCell.FormulaR1C1 = "1"
Range("M16").Select
ActiveCell.FormulaR1C1 = "1 von 3"
Range("M17").Select
ActiveCell.FormulaR1C1 = "2 von 3"
Range("M18").Select
ActiveCell.FormulaR1C1 = "3 von 3"
Range("M19").Select
End Sub

Ich habe leider überhaupt keinen Plan, wie ich das alle in eine wenn dann Bedingung unterbringen soll. Wer kann mir hierbei helfen?
Vielen lieben Dank,
Martin

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Beispielmappe bitte
31.01.2021 13:00:20
Werner
Hallo,
mach mal eine Beispielmappe mit ein paar Beispieldaten, in der du aufzeigst, was du haben willst.
Bitte auch mit vorher/nachher, damit man dein Wunschergebnis sieht.
Gruß Werner
AW: Beispielmappe bitte
31.01.2021 14:02:20
Martin
Hallo Werner, ich habe die Datei mal hochgeladen.
https://www.herber.de/bbs/user/143472.xlsx
sind 2 Tabellenblätter drin. Vorher und nachher. In Vorher sind in Spalte I einige Zeilen mit Zahlen größer 1 , in der Nachher Tabelle habe ich diese Zeilen per Hand aufgelöst und daraus jeweils eine Zeile gemacht...
AW: Beispielmappe bitte
31.01.2021 14:05:14
Martin
... und im Nachher habe ich die neuen Zeilen auch gelb markiert. Meine Frau so zu mir: das muss doch ganz einfach sein. Ich so: naja so einfach ist es nun auch wieder nicht :-)
Klar per Hand geht's schon, aber wenn man mal 500 Zeilen hat und alle prüft und ersetzt, dann dauert das. Mit VBA geht das aber sicher weniger fehleranfällig als per Hand.
Danke und Gruß,
Martin
Anzeige
AW: Beispielmappe bitte
31.01.2021 16:55:23
Martin
Hallo Werner & alle anderen,
nach einigem Basteln habe ich nun diesen Code: 
Sub Zeilenkopieren()
Dim r As Long
Dim LRow As Long
LRow = Cells(Rows.Count, "I").End(xlUp).Row
If LRow  1 Then
Rows(r).Select
Selection.Copy
Rows(r + 1).Select
Selection.Insert Shift:=xlDown
Rows(r + 1).Select
Cells(r, "I") = "1 "
End If
End If
Next r
End Sub
Der Code sucht die erste Zeile in der keine 1 steht und kopiert diese dann. Aber eigentlich bräuchte ich in dem Fall ja 2 Zeilen und nicht nur eine.... Dann soll eigentlich auch die Zelle in der die 3 steht ersetzt werden, aber das tut er nicht so wirklich sondern es entsteht eine Dauerschleife. Ein Schritt weiter aber noch lange nicht am Ziel...
Danke für weitere Hilfe.
LG
Martin
Anzeige
AW: Beispielmappe bitte
31.01.2021 17:42:08
Werner
Hallo,
Public Sub Duplizieren()
Dim i As Long, z As Long
Application.ScreenUpdating = False
With Worksheets("Vorher")
For i = .Cells(.Rows.Count, "I").End(xlUp).Row To 5 Step -1
If IsNumeric(.Cells(i, "I")) Then
If .Cells(i, "I") > 1 Then
.Rows(i).Copy
.Rows(i).Offset(1).Resize(.Cells(i, "I") - 1).Insert
For z = 1 To .Cells(i, "I")
.Cells(i, "M").Offset(z - 1) = z & " von " & .Cells(i, "I")
Next z
End If
End If
Next i
End With
Application.CutCopyMode = False
End Sub
Gruß Werner
AW: Beispielmappe bitte
31.01.2021 18:04:32
Martin
Hallo Werner,
wow, das sieht dann doch etwas einfacher aus als meine Lösung. Danke dir!! Eine Kleinigkeit fehlt in deinem Code aber noch. Am Ende müsste überall in Spalte I eine 1 stehen. Ich habe das jetzt so gelöst:
Public Sub Duplizieren()
Dim i As Long, z As Long, y As Long
Application.ScreenUpdating = False
With Worksheets("Vorher")
For i = .Cells(.Rows.Count, "I").End(xlUp).Row To 5 Step -1
If IsNumeric(.Cells(i, "I")) Then
If .Cells(i, "I") > 1 Then
.Rows(i).Copy
.Rows(i).Offset(1).Resize(.Cells(i, "I") - 1).Insert
For z = 1 To .Cells(i, "I")
.Cells(i, "M").Offset(z - 1) = z & " von " & .Cells(i, "I")
Next z
For y = 1 To .Cells(i, "I")
.Cells(i, "I").Offset(y - 1) = "1"
Next y
End If
End If
Next i
End With
Application.CutCopyMode = False
End Sub
Scheint zu funktionieren :-)
Ich hatte mich auch schon einer Lösung genähert, aber deine sieht deutlich sauberer aus.
So sah es bei mir aus, allerdings hätte ich jetzt noch für alle weiteren möglichen Werte etwas programmieren müssen, habe es nur für 2 und 3 Zeilen geschafft:
Sub Zeilenkopieren()
Dim r As Long
Dim LRow As Long
LRow = Cells(Rows.Count, "I").End(xlUp).Row
If LRow For r = 5 To LRow
If IsNumeric(Cells(r, "I")) Then
If Cells(r, "I") = 2 Then
Rows(r).Select
Selection.Copy
Rows(r + 1).Select
Selection.Insert Shift:=xlDown
Rows(r + 1).Select
Cells(r, "I") = "1 "
Cells(r, "M") = "1 von 2"
Cells(r + 1, "I") = "1 "
Cells(r + 1, "M") = "2 von 2 "
End If
If Cells(r, "I") = 3 Then
Rows(r).Select
Selection.Copy
Rows(r + 1).Select
Selection.Insert Shift:=xlDown
Rows(r).Select
Selection.Copy
Rows(r + 1).Select
Selection.Insert Shift:=xlDown
Rows(r).Select
Cells(r, "I") = "1 "
Cells(r, "M") = "1 von 3"
Cells(r + 1, "I") = "1 "
Cells(r + 1, "M") = "2 von 3"
Cells(r + 2, "I") = "1 "
Cells(r + 2, "M") = "3 von 3"
End If
End If
Next r
End Sub
Danke nochmals!!
Anzeige
AW: Beispielmappe bitte
31.01.2021 19:10:24
Werner
Hallo,
da brauchst du nicht noch eine Schleife. 
Public Sub Duplizieren()
Dim i As Long, z As Long
Application.ScreenUpdating = False
With Worksheets("Vorher")
For i = .Cells(.Rows.Count, "I").End(xlUp).Row To 5 Step -1
If IsNumeric(.Cells(i, "I")) Then
If .Cells(i, "I") > 1 Then
.Rows(i).Copy
.Rows(i).Offset(1).Resize(.Cells(i, "I") - 1).Insert
For z = 1 To .Cells(i, "I")
.Cells(i, "M").Offset(z - 1) = z & " von " & .Cells(i, "I")
Next z
.Cells(i, "I").Resize(.Cells(i, "I")) = 1
End If
End If
Next i
End With
Application.CutCopyMode = False
End Sub
Gruß Werner
Anzeige
AW: Beispielmappe bitte
31.01.2021 20:20:45
Martin
Danke dir Werner. Schon wieder zu kompliziert gedacht...
Eine Nachfrage hätte ich noch. Auf einem anderen Tabellenblatt habe ich Bezüge zu dieser Tabelle. Allerdings erkennt Excel nicht, dass durch das Makro neue Zeilen eingefügt wurden sind und somit fehlen genau diese Zeilen in der anderen Tabelle (Excel lässt diese einfach aus - also z.B. nach Bezug zu Zeile 15 kommt nicht Bezug zu Zeile 16 (die mit dem Makro eingefügt wurde), sondern zu Zeile 17). Gibt es da einen geschickten Weg das zu lösen?
Danke.
Gruß,
Martin
AW: Beispielmappe bitte
01.02.2021 16:17:28
Martin
...meine hemdsärmelige Lösung: ich kopiere per VBA einfach die erste Zeile mit allen Formeln nochmal übers andere Tabellenblatt. Dann passts wieder :-)
Danke und Gruß,
Martin
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige