Public
Sub
Aufteilen()
Dim
objDictionary
As
Object
Dim
objCell
As
Range, objCopyRange
As
Range
Dim
objWorkbook
As
Workbook
Dim
ialngIndex
As
Long
Dim
avntValues
As
Variant
, avntKeys
As
Variant
Dim
strFirstAddress
As
String
Application.ScreenUpdating =
False
With
Tabelle1
avntValues = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).
End
(xlUp)).Value2
End
With
Set
objDictionary = CreateObject(
"Scripting.Dictionary"
)
For
ialngIndex = LBound(avntValues)
To
UBound(avntValues)
objDictionary(avntValues(ialngIndex, 1)) = vbNullString
Next
avntKeys = objDictionary.Keys
Set
objDictionary =
Nothing
With
Tabelle1
For
ialngIndex = LBound(avntKeys)
To
UBound(avntKeys)
Set
objCell = .Columns(1).Find(What:=avntKeys(ialngIndex), _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=
True
)
If
Not
objCell
Is
Nothing
Then
strFirstAddress = objCell.Address
Set
objCopyRange = .Cells(1, 1)
Do
Set
objCopyRange = Union(objCopyRange, objCell)
Set
objCell = .Columns(1).FindNext(objCell)
Loop
Until
objCell.Address = strFirstAddress
Set
objWorkbook = Workbooks.Add(xlWBATWorksheet)
objCopyRange.EntireRow.Copy Destination:=objWorkbook.Worksheets(1).Cells(1, 1)
objWorkbook.Close SaveChanges:=
True
, Filename:= _
ThisWorkbook.Path &
"\" & avntKeys(ialngIndex) & "
.xls"
Set
objWorkbook =
Nothing
Set
objCell =
Nothing
Set
objCopyRange =
Nothing
End
If
Next
End
With
Application.ScreenUpdating =
True
End
Sub