Daten einer Zeile in mehrere Zeilen auft

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Schwimmzeiten() Dim TB1 As Worksheet, TB2 As Worksheet Dim Z1 As Integer, i As Integer, Anz As Integer, SP1 As Integer Dim LR1 As Integer, LR2 As Integer, LC As Integer Set TB1 = Sheets("Sheet1") Z1 = 2 'Daten ab Zeile 2 SP1 = 35 'Spalte AI mit erstem Ja LR1 = TB1.Cells(TB1.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte Set TB2 = Sheets.Add(after:=Sheets(Sheets.Count)) 'neues Blatt erstellen TB1.Rows(1).Copy TB2.Rows(1) 'Überschrift Kopieren For i = Z1 To LR1 LC = TB1.Cells(i, TB1.Columns.Count).End(xlToLeft).Column 'letzte Spalte der Zeile Anz = WorksheetFunction.CountIf(TB1.Cells(i, SP1).Resize(1, LC - SP1 + 1), "Ja") 'Ja ab AI zählen LR2 = TB2.Cells(TB2.Rows.Count, "A").End(xlUp).Row + 1 ' erste freie Zielzeile TB1.Rows(i).Copy TB2.Rows(LR2).Resize(Anz + 1) ' x mal kopieren Next i End Sub

Wow, das ging ja schneller als ich mich mit wieder mit der Tabelle beschäftigen konnte - vielen Dank! Funktioniert im Prinzip super, Problem ist nur noch, dass er nicht den Inhalt der ersten Zeile (2. Schwimmzeit) kopieren und so oft wiederholen soll, wie er "ja" findet, sondern jeweils die Info, die er nach dem nächsten "ja" findet. Hab ich mich wahrscheinlich missverständlich ausgedrückt.
Im Prinzip also: wenn AI = ja, dann Zeile kopieren, ans Ende der Liste anhängen und den Inhalt der Zellen AJ-AQ kopieren und in die neue Zeile in AA-AH reinkopieren (überschreiben). Dann weitersuchen nach ja (AR= ja, dann Zelle kopieren, ans Ende der Liste anhängen und den Inhalt der Zellen AS-AZ kopieren und in die weitere neue Zeile in AA-AH reinkopieren (überschreiben). Die ursprüngliche Zeile nach dem letzten gefundenen "ja" solange durchgehen und jeweils wiederholen, bis kein "ja" mehr gefunden wird (es gibt max. 15 "ja"). Am Ende können die Spalten AR-FE gelöscht werden. Die Spalten bleiben fix in der Reihenfolge, es kann also durchaus auf die konkreten Spalten abgestellt werden.
Wäre super, wenn es hierfür eine Lösung gäbe. Händisch copy paste kann es ja nicht sein...

Hallo nochmal
versuch es mal so


Sub Schwimmzeiten()
Dim TB1 As Worksheet, TB2 As Worksheet
Dim Z1 As Integer, i As Integer, J As Integer, Anz As Integer, SP1 As Integer
Dim LR1 As Integer, LR2 As Integer, Zeile As Integer, LC As Integer
Set TB1 = Sheets("Sheet1")
Z1 = 2 'Daten ab Zeile 2
SP1 = 35 'Spalte mit erstem Ja
LR1 = TB1.Cells(TB1.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte
Set TB2 = Sheets.Add(after:=Sheets(Sheets.Count)) 'neues Blatt erstellen
TB1.Cells(1, 1).Resize(1, SP1 - 1).Copy TB2.Cells(1, 1) 'Überschrift Kopieren
For i = Z1 To LR1
LC = TB1.Cells(i, TB1.Columns.Count).End(xlToLeft).Column 'letzte Spalte der Zeile
Anz = WorksheetFunction.CountIf(TB1.Cells(i, SP1).Resize(1, LC - SP1 + 1), "Ja") + 1 'Ja ab AI zählen
LR2 = TB2.Cells(TB2.Rows.Count, "A").End(xlUp).Row + 1 ' erste freie Zielzeile
TB1.Rows(i).Copy TB2.Rows(LR2).Resize(Anz)  ' x mal kopieren
For J = 0 To Anz - 1
TB2.Cells(LR2 + J, SP1).Resize(1, LC - SP1 + 1).Delete xlToLeft 'Rest ab AI weglöschen
If J

LG UweD

Beliebteste Forumthreads (12 Monate)

Daten einer Zeile in mehrere Zeilen auft

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread