Gruppe
Allgemein
Problem
Die Daten aus obiger Tabelle sollen gemäß den Nummern in Spalte A auf neue Arbeitsblätter verteilt werden.
StandardModule: basMain
Sub EgaleSpeichern()
Dim rng As Range, rngCur As Range
Dim lngRow As Long
Application.ScreenUpdating = False
Set rngCur = Range("A1").CurrentRegion
rngCur.Sort _
key1:=Range("A2"), _
order1:=xlAscending, _
header:=xlYes
lngRow = 2
Do Until IsEmpty(rngCur.Cells(lngRow, 1))
If rngCur.Cells(lngRow, 1) <> rngCur.Cells(lngRow - 1, 1) Then
rngCur.AutoFilter _
field:=1, _
Criteria1:=rngCur.Cells(lngRow, 1)
Set rng = rngCur.SpecialCells(xlCellTypeVisible)
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = rngCur.Cells(lngRow, 1)
rng.Copy Range("A1")
End If
lngRow = lngRow + 1
Loop
Worksheets(1).Select
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = False
End Sub