Hallo Wastl,
hier doch noch mein Senf, braucht bei 150.000 Zeilen und 80 Typen ~18 Sekunden.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub test()
Dim VX As Variant
VX = Sheets("Tabelle1").Range("A1:M150000") 'nur zum Testen, du übergibst dein Array!
wastl VX, 5 'Array und die Spalte mit der Typenkennzeichnung übergeben!
End Sub
Sub wastl(Field As Variant, compareColumn As Long)
Dim objSh As Worksheet, myCol() As New Collection
Dim vntSheets As Variant, vntTmp() As Variant, vntOut() As Variant
Dim lngRow As Long, lngCol As Long, lngIndex As Long, lngTmp As Long
Dim vntRet As Variant, lngCalc As Long
Dim t As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With
Redim vntTmp(LBound(Field, 1) To UBound(Field, 1))
For lngRow = LBound(Field, 1) To UBound(Field, 1)
vntTmp(lngRow) = Field(lngRow, compareColumn)
Next
vntSheets = UniqueList(vntTmp)
Redim myCol(UBound(vntSheets))
Erase vntTmp
Redim vntTmp(1 To UBound(Field, 2))
For lngRow = LBound(Field, 1) To UBound(Field, 1)
vntRet = Application.Match(Field(lngRow, compareColumn), vntSheets, 0) - 1
For lngCol = LBound(Field, 2) To UBound(Field, 2)
vntTmp(lngCol) = Field(lngRow, lngCol)
Next
myCol(vntRet).Add vntTmp
Next
For lngIndex = 0 To UBound(vntSheets)
If SheetExist(vntSheets(lngIndex)) Then
Set objSh = Sheets(CStr(vntSheets(lngIndex)))
With objSh.Range("A1")
.CurrentRegion.Offset(1, 0).Resize(.CurrentRegion.Rows.Count - 1, .CurrentRegion.Columns.Count).ClearContents
End With
Else
Set objSh = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
objSh.Name = CStr(vntSheets(lngIndex))
End If
Redim vntOut(1 To myCol(lngIndex).Count, 1 To UBound(Field, 2) + IIf(LBound(Field, 2) = 0, 1, 0))
For lngCol = 1 To myCol(lngIndex).Count
vntTmp = myCol(lngIndex).Item(lngCol)
For lngTmp = 1 To UBound(vntTmp)
vntOut(lngCol, lngTmp) = vntTmp(lngTmp)
Next
Next
objSh.Range("A2").Resize(UBound(vntOut, 1), UBound(vntOut, 2)) = vntOut
Next
ErrExit:
If Err.Number <> 0 Then
MsgBox "Fehler:" & vbTab & Err.Number & vbLf & vbLf & Err.Description, vbExclamation, "Fehler"
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
End With
Set objSh = Nothing
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Worksheets
If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function
Private Function UniqueList(Matrix As Variant, Optional Sorted As Boolean = True) As Variant
Dim objDic As Object, varTmp() As Variant, lngIndex As Long
Set objDic = CreateObject("Scripting.Dictionary")
For lngIndex = LBound(Matrix) To UBound(Matrix)
objDic(Matrix(lngIndex)) = 0
Next
varTmp = objDic.keys
If Sorted Then QuickSort varTmp
UniqueList = varTmp
Set objDic = Nothing
End Function
Private Sub QuickSort(Data() As Variant, Optional UG, Optional OG)
Dim P1&, P2&, T1 As Variant, T2 As Variant
UG = IIf(IsMissing(UG), LBound(Data), UG)
OG = IIf(IsMissing(OG), UBound(Data), OG)
P1 = UG
P2 = OG
T1 = Data((P1 + P2) / 2)
Do
Do While (Data(P1) < T1)
P1 = P1 + 1
Loop
Do While (Data(P2) > T1)
P2 = P2 - 1
Loop
If P1 <= P2 Then
T2 = Data(P1)
Data(P1) = Data(P2)
Data(P2) = T2
P1 = P1 + 1
P2 = P2 - 1
End If
Loop Until (P1 > P2)
If UG < P2 Then QuickSort Data, UG, P2
If P1 < OG Then QuickSort Data, P1, OG
End Sub