Sub
Aufteilen()
Dim
arr
As
Variant
Dim
i
As
Long
Dim
j
As
Long
Dim
lRow
As
Long
Dim
WS
As
Worksheet
arr = ActiveSheet.UsedRange
For
i = LBound(arr)
To
UBound(arr)
If
WorkSheetExists(arr(i, 1))
Then
Set
WS = Worksheets(arr(i, 1))
Else
Set
WS = Worksheets.Add(after:=Worksheets(Worksheets.Count))
ActiveSheet.Name = arr(i, 1)
End
If
lRow = WS.Cells(Rows.Count, 1).
End
(xlUp).Row + 1
For
j = LBound(arr)
To
UBound(arr, 2)
WS.Cells(lRow, j) = arr(i, j)
Next
j
Next
i
End
Sub
Function
WorkSheetExists(
ByVal
WS
As
Variant
)
As
Boolean
On
Error
Resume
Next
WorkSheetExists =
Not
Worksheets(WS)
Is
Nothing
End
Function