Gruppe
Allgemein
Problem
Die Tabelle soll gruppenweise nach Kriterium Spalte A in neue Tabellen aufgeteilt werden.
StandardModule: basMain
Sub Kopieren()
Dim wks As Worksheet
Dim iRow As Integer, iStart As Integer
Application.ScreenUpdating = False
Set wks = ActiveSheet
iRow = 2
iStart = iRow
Do Until IsEmpty(wks.Cells(iRow, 1))
If wks.Cells(iRow, 1) <> wks.Cells(iRow + 1, 1) Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = wks.Cells(iRow, 1)
wks.Rows(iStart & ":" & iRow).Copy Range("A1")
iStart = iRow + 1
End If
iRow = iRow + 1
Loop
Worksheets(1).Select
Application.ScreenUpdating = True
End Sub