Option
Explicit
Sub
KritToSheet()
Dim
objShSource
As
Worksheet, objSh
As
Worksheet
Dim
rng
As
Range, rngCopy
As
Range
Dim
varTemp
As
Variant
Dim
strFind
As
String
, strFirst
As
String
Dim
lngLast
As
Long
, lngAct
As
Long
Dim
rngCol
As
Range, intCol
As
Integer
Dim
löschen()
Dim
i
As
Long
ReDim
löschen(0)
On
Error
Resume
Next
Set
rngCol = Application.InputBox(
"Markieren Sie eine Zelle in der"
& vbLf &
"gewünschten Spalte! (Kriterium)"
,
"Tabelle aufteilen"
, ActiveCell.Address, Type:=8)
If
rngCol
Is
Nothing
Then
Exit
Sub
intCol = rngCol(1).Column
On
Error
GoTo
ErrExit
With
Application
.ScreenUpdating =
False
.EnableEvents =
False
.DisplayAlerts =
False
.Calculation = xlCalculationManual
.Cursor = xlWait
End
With
rngCol.Parent.Copy After:=Sheets(Sheets.Count)
Set
objShSource = Sheets(Sheets.Count)
With
objShSource
lngLast = .Cells(Rows.Count, intCol).
End
(xlUp).Row
lngAct = lngLast
Do
While
lngAct > 1
strFind = .Cells(2, intCol)
Set
rngCol = .Range(.Cells(2, intCol), .Cells(lngAct, intCol))
Set
rng = rngCol.Find(what:=strFind, lookat:=xlWhole)
If
Not
rng
Is
Nothing
Then
strFirst = rng.Address
Do
If
rngCopy
Is
Nothing
Then
Set
rngCopy = .Rows(rng.Row)
Else
Set
rngCopy = Union(rngCopy, .Rows(rng.Row))
End
If
Set
rng = rngCol.FindNext(rng)
Loop
While
Not
rng
Is
Nothing
And
strFirst <> rng.Address
End
If
If
Not
rngCopy
Is
Nothing
Then
Set
objSh = Worksheets.Add(After:=Sheets(Sheets.Count))
On
Error
Resume
Next
objSh.Name = strFind
If
Err.Number <> 0
Then
objSh.Name = strFind & Format(Now,
" hhmmss"
)
Err.Clear
End
If
ReDim
Preserve
löschen(UBound(löschen) + 1)
löschen(UBound(löschen)) = objSh.Name
On
Error
GoTo
ErrExit
rngCopy.Copy
objSh.Cells(2, 1).PasteSpecial xlValues
objSh.Cells(2, 1).PasteSpecial xlFormats
Application.CutCopyMode =
False
objShSource.Rows(1).Copy objSh.Rows(1)
rngCopy.Delete
Set
rngCopy =
Nothing
Set
objSh =
Nothing
End
If
lngAct = .Cells(Rows.Count, intCol).
End
(xlUp).Row
Loop
.Delete
End
With
Application.DisplayAlerts =
False
For
i = 1
To
UBound(löschen)
Worksheets(löschen(i)).Delete
Next
i
Application.DisplayAlerts =
True
ErrExit:
Set
objShSource =
Nothing
Set
rngCol =
Nothing
With
Application
.ScreenUpdating =
True
.EnableEvents =
True
.DisplayAlerts =
True
.Calculation = xlCalculationAutomatic
.Cursor = xlDefault
End
With
End
Sub