Сортировка - поиск

Option Explicit
 
Public Enum F_Compare
    [Числовые элементы] = 0
    [Текстовые элементы] = 1
    [По убыванию] = 2
    [Игнорировать регистр] = 4
    [Учёт длины элементов] = 8
End Enum
Private FMax As Long, j() As String, n&, s$
 
Public Function Find&(List As Variant, ByVal Elm As Variant, _
Optional Flag As F_Compare)
    'Бинарный поиск
    'Возврат положительного числа найденной позиции элемента в списке
    'Арг: Список // Элемент // Флаги сравнений
    Find = LBound(List)
    FMax = UBound(List)
 
1
    While FMax > Find
        Find = Fix((Find + FMax) / 2)
        On Compare(Elm, List(Find), Flag) + 1 GoTo 2, 3
        FMax = Find - 1
        GoTo 1
2
        Exit Function
3
        Find = Find + 1
    Wend
    Find = -1
End Function
 
Public Function Sort(List As Variant, Flag As F_Compare, Optional ByVal Min&, Optional ByVal Max& = -1) As Variant
    'Быстрая сортировка
    'Арг: Список // Флаги сравнений // [Нижний индекс] // [Верхний индекс]
    'Возвращаемое значение: Отсортированный список
    If Max < 0 Then Max = UBound(List)
 
    If TypeName(List) = "String()" Then
        j = List
        Sort_Str j, Flag, Min, Max
        Sort = j
    Else
        Sort = List
        Sort_Var Sort, Flag, Min, Max
    End If
End Function
 
Private Sub Sort_Str(List() As String, Flag As F_Compare, Min&, Max&)
    'Рекурсивный алгоритм быстрой сортировки
    Dim i1&, i2&
    If Max - Min < 1 Then Exit Sub 'Пройден весь список
    n = Fix((Max - Min + 1) / 5 + Min) 'Выбрать разделяющее значение.
    s = List(n)
    List(n) = List(Min) 'Переместить его вперед.
    i1 = Min: i2 = Max
 
    Do
 
        While Compare(List(i2), s, Flag) >= 0 'Просмотр сверху вниз от i2 до значения >= s
            i2 = i2 - 1
            If i2 <= i1 Then List(i1) = s: Exit Do
        Wend
        List(i1) = List(i2) 'Поменять местами значения i1 и i2.
        '-----------
        i1 = i1 + 1 'Просмотр снизу вверх от i1 до значения < s.
 
        While Compare(List(i1), s, Flag) < 0
            i1 = i1 + 1
            If i1 >= i2 Then i1 = i2: List(i2) = s: Exit Do
        Wend
        List(i2) = List(i1) 'Поменять местами значения i1 и i2.
    Loop
    '---------------------------------Сортировать два подсписка.
    On Error GoTo 1
 
    While List(i1) = List(i1 - 1) 'Сокращение диапазона поиска для Max
        i1 = i1 - 1
    Wend
    Sort_Str List, Flag, Min, i1
1
    On Error GoTo 2
 
    While List(i1) = List(i1 + 1) 'Сокращение диапазона поиска для Min
        i1 = i1 + 1
    Wend
    Sort_Str List, Flag, i1 + 1, Max
2
End Sub
 
Private Sub Sort_Var(List As Variant, Flag As F_Compare, Min&, Max&)
    'Рекурсивный алгоритм быстрой сортировки
    Dim i1&, i2&
    Static n&, v As Variant
    If Max - Min < 1 Then Exit Sub 'Пройден весь список
    n = Fix((Max - Min + 1) / 5 + Min) 'Выбрать разделяющее значение.
    v = List(n)
    List(n) = List(Min) 'Переместить его вперед.
    i1 = Min: i2 = Max
 
    Do
 
        While Compare(List(i2), v, Flag) >= 0 'Просмотр сверху вниз от i2 до значения >= v
            i2 = i2 - 1
            If i2 <= i1 Then List(i1) = v: Exit Do
        Wend
        List(i1) = List(i2) 'Поменять местами значения i1 и i2.
        '-----------
        i1 = i1 + 1 'Просмотр снизу вверх от i1 до значения < v.
 
        While Compare(List(i1), v, Flag) < 0
            i1 = i1 + 1
            If i1 >= i2 Then i1 = i2: List(i2) = v: Exit Do
        Wend
        List(i2) = List(i1) 'Поменять местами значения i1 и i2.
    Loop
    '---------------------------------Сортировать два подсписка.
    On Error GoTo 1
 
    While List(i1) = List(i1 - 1) 'Сокращение диапазона поиска для Max
        i1 = i1 - 1
    Wend
    Sort_Var List, Flag, Min, i1
1
    On Error GoTo 2
 
    While List(i1) = List(i1 + 1) 'Сокращение диапазона поиска для Min
        i1 = i1 + 1
    Wend
    Sort_Var List, Flag, i1 + 1, Max
2
End Sub
 
Public Function Compare&(Elm1 As Variant, Elm2 As Variant, ByVal Flag As F_Compare)
    'Улучшенная функция сравнения
    If Elm1 = Elm2 Then Exit Function
    On Flag GoTo 1, 2, 3, 2, 5, 2, 7, 2, 9, 2, 11, 2, 13, 2, 15
    Compare = (CDbl(Elm1) < CDbl(Elm2)) * 2 + 1
    Exit Function
2
    Compare = (CDbl(Elm2) < CDbl(Elm1)) * 2 + 1
    Exit Function
1
    Compare = StrComp(Elm1, Elm2, vbBinaryCompare)
    Exit Function
3
    Compare = StrComp(Elm2, Elm1, vbBinaryCompare)
    Exit Function
5
    Compare = StrComp(Elm1, Elm2, vbTextCompare)
    Exit Function
7
    Compare = StrComp(Elm2, Elm1, vbTextCompare)
    Exit Function
9
    Compare = Sgn(LenB(Elm1) - LenB(Elm2))
    If Compare = 0 Then Compare = StrComp(Elm1, Elm2, vbBinaryCompare)
    Exit Function
11
    Compare = Sgn(LenB(Elm2) - LenB(Elm1))
    If Compare = 0 Then Compare = StrComp(Elm2, Elm1, vbBinaryCompare)
    Exit Function
13
    Compare = Sgn(LenB(Elm1) - LenB(Elm2))
    If Compare = 0 Then Compare = StrComp(Elm1, Elm2, vbTextCompare)
    Exit Function
15
    Compare = Sgn(LenB(Elm2) - LenB(Elm1))
    If Compare = 0 Then Compare = StrComp(Elm2, Elm1, vbTextCompare)
    Exit Function
End Function