Sub Test()
Dim Zei As Long, colC As New Collection, C As Long, ZeiC As Long
On Error Resume Next
With Worksheets("Tabelle1")
For Zei = 1 To .Cells(Rows.Count, 3).End(xlUp).Row
colC.Add Item:=.Cells(Zei, 3).Value, key:=.Cells(Zei, 3).Value
Next Zei
For C = 1 To colC.Count
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = colC(C)
.Rows(1).Copy Destination:=Worksheets(colC(C)).Cells(1, 1)
ZeiC = 1
For Zei = 1 To .Cells(Rows.Count, 3).End(xlUp).Row
If .Cells(Zei, 3) = ActiveSheet.Name Then
ZeiC = ZeiC + 1
.Rows(Zei).Copy Destination:=ActiveSheet.Cells(ZeiC, 1)
End If
Next Zei
Next C
End With
End Sub
Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen