Option Explicit
Sub TestBereichSortierenUndBereinigen()
Dim vArr(
)
As Variant, sArr(
)
As String
vArr =
Range(
"A1:A" &
Range(
"A65536").End(xlUp).Row).Value
Range(
"B1:B" &
Range(
"A65536").End(xlUp).Row).ClearContents
sArr =
Split(ArraySort(vArr),
",")
Cells(
1,
"B").Resize(
UBound(sArr),
1) = Application.Transpose(sArr)
End Sub
Function ArraySort(vArr As Variant) As String
'Sortieren eines einstelligen Arrays über eine Collection
Dim i
As Long, oCol
As New Collection
For i =
1 To UBound(vArr)
CollectionAddItem oCol, vArr(i,
1)
Next i
For i =
1 To oCol.Count
ArraySort = ArraySort & oCol.Item(i) &
","
Next i
End Function
Function CollectionAddItem(oCol As Collection, ByVal sItem As String, Optional iPos As Integer, Optional ByVal vKey As Variant) As Long
'Function fügt einen Eintrag sortiert in eine Collectionsammlung ein
Dim nStart
As Long, nEnd
As Long
If Trim$(sItem) =
"" Then Exit Function
With oCol
If iPos <>
0 Then .Add sItem, vKey,
1:
Exit Function
If .Count <
1 Then .Add sItem, vKey:
Exit Function 'wenn Collection-Objekt noch leer ist
'Neuen Eintrag mit 1. Eintrag vergleichen
If .Item(
1) > sItem
Then
.Add sItem, vKey,
1 'an 1. Position einfügen
'jetzt mit letzten Eintrag vergleichen
ElseIf .Item(
1)
Like sItem
Or .Item(.Count)
Like sItem
Then
Exit Function
ElseIf .Item(.Count) < sItem
Then
.Add sItem, vKey: CollectionAddItem = .Count +
1 'an letzter Position einfügen
Else
'durch binäre Suche die korrekte Position ermitteln
nStart =
1: nEnd = .Count
Do
CollectionAddItem =
(nStart + nEnd) \
2
If CollectionAddItem = nStart
Then Exit Do
'Vergleich
If .Item(CollectionAddItem) > sItem
Then nEnd = CollectionAddItem
If .Item(CollectionAddItem) < sItem
Then nStart = CollectionAddItem
If .Item(CollectionAddItem) = sItem
Then Exit Function
Loop
On Error Resume Next
.Add sItem, vKey, , CollectionAddItem
CollectionAddItem = CollectionAddItem +
1
End If
End With
End Function