Option
Explicit
Private
Const
Startzeile& = 2
Sub
ListeSortieren()
Dim
i&, j&, k&, n&, lz&, objSL
As
Object
, arrLager(), arrTab(), tmp()
Set
objSL = CreateObject(
"System.Collections.SortedList"
)
With
Tabelle1
arrTab = .UsedRange.Offset(1, 0).Value
arrLager = .Range(.Cells(Startzeile, 1), .Cells(Rows.Count, 1).
End
(xlUp)).Value
For
i = 1
To
UBound(arrLager)
If
arrLager(i, 1) <>
""
Then
objSL(arrLager(i, 1)) =
""
Next
ReDim
arrLager(1
To
objSL.Count, 1
To
1)
For
i = 1
To
objSL.Count
arrLager(i, 1) = objSL.GetKey(i - 1)
Next
If
.Cells(Rows.Count, 1).
End
(xlUp).Row >= Startzeile
Then
.Range(.Cells(Startzeile, 1), .Cells(.Cells(Rows.Count, 1).
End
(xlUp).Row, 11)).ClearContents
End
If
For
i = 1
To
UBound(arrLager)
For
j = 1
To
UBound(arrTab)
If
arrLager(i, 1) = arrTab(j, 1)
Then
n = n + 1
ReDim
Preserve
tmp(1
To
UBound(arrTab, 2), 1
To
n)
For
k = 1
To
UBound(arrTab, 2)
tmp(k, n) = arrTab(j, k)
Next
k
End
If
Next
j
tmp = Application.Transpose(tmp)
If
n > 1
Then
Call
QuickSort(LBound(tmp), UBound(tmp), tmp, 5)
If
.Cells(Startzeile, 1) <>
""
Then
lz = .Cells(Rows.Count, 1).
End
(xlUp).Row + 3
Else
lz = Startzeile
End
If
If
n > 1
Then
.Cells(lz, 1).Resize(UBound(tmp, 1), UBound(tmp, 2)) = tmp
Else
Cells(lz, 1).Resize(1, UBound(tmp) - LBound(tmp) + 1) = tmp
End
If
Erase
tmp
n = 0
Next
i
End
With
End
Sub
Private
Sub
QuickSort(lngLBound
As
Long
, lngUBound
As
Long
, avntArray
As
Variant
, lngSortColumn
As
Long
)
Dim
lngIndex1
As
Long
, lngIndex2
As
Long
, lngColumn
As
Long
Dim
vntBuffer
As
Variant
, vntTemp
As
Variant
lngIndex1 = lngLBound
lngIndex2 = lngUBound
vntTemp = avntArray((lngLBound + lngUBound) \ 2, lngSortColumn)
Do
Do
While
avntArray(lngIndex1, lngSortColumn) < vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do
While
vntTemp < avntArray(lngIndex2, lngSortColumn)
lngIndex2 = lngIndex2 - 1
Loop
If
lngIndex1 <= lngIndex2
Then
For
lngColumn = LBound(avntArray, 2)
To
UBound(avntArray, 2)
vntBuffer = avntArray(lngIndex1, lngColumn)
avntArray(lngIndex1, lngColumn) = avntArray(lngIndex2, lngColumn)
avntArray(lngIndex2, lngColumn) = vntBuffer
Next
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
End
If
Loop
Until
lngIndex1 > lngIndex2
If
lngLBound < lngIndex2
Then
Call
QuickSort(lngLBound, lngIndex2, avntArray, lngSortColumn)
If
lngIndex1 < lngUBound
Then
Call
QuickSort(lngIndex1, lngUBound, avntArray, lngSortColumn)
End
Sub