'Сортировка массива
'Автор: Слэн
'Тема на форуме: http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=8&TID=26414&MID=231854#message231854
'===========================================================================================================================
Private Type QuickStack
    'тип для QuickSort
    Low As Long
    High As Long
End Type
Public Sub QuickSortNonRecursive___(SortArray())
Dim i As Long, j As Long, lb As Long, ub As Long
Dim stack() As QuickStack, stackpos As Long, ppos As Long, pivot As Variant, swp, maxstack&
    On Error GoTo er
    ReDim stack(1 To 16)
    stackpos = 1

    stack(1).Low = LBound(SortArray)
    stack(1).High = UBound(SortArray)
    Do
        'Взять границы lb и ub текущего массива из стека.
        lb = stack(stackpos).Low
        ub = stack(stackpos).High
        stackpos = stackpos - 1
        Do
            'Шаг 1. Разделение по элементу pivot
            ppos = (lb + ub) \ 2
            i = lb: j = ub: pivot = SortArray(ppos)
            Do
                While SortArray(i) < pivot: i = i + 1: Wend
                While pivot < SortArray(j): j = j - 1: Wend
                If i > j Then Exit Do
'                If i <> j Then
                 swp = SortArray(i): SortArray(i) = SortArray(j): SortArray(j) = swp
'                End If
                i = i + 1
                j = j - 1
'                End If
           Loop While i <= j

            'Сейчас указатель i указывает на начало правого подмассива,
            'j - на конец левого lb ? j ? i ? ub.
            'Возможен случай, когда указатель i или j выходит за границу массива
            'Шаги 2, 3. Отправляем большую часть в стек  и двигаем lb,ub

            If i < ppos Then   'правая часть больше
                If i < ub Then
                    stackpos = stackpos + 1
                    stack(stackpos).Low = i
                    stack(stackpos).High = ub
                End If
                ub = j        'следующая итерация разделения будет работать с левой частью
            Else
                If j > lb Then
                    stackpos = stackpos + 1
                    stack(stackpos).Low = lb
                    stack(stackpos).High = j
                End If
                lb = i
            End If
'            If maxstack < stackpos Then maxstack = stackpos
        Loop While lb < ub
    Loop While stackpos
    Exit Sub
er: ReDim Preserve stack(1 To UBound(stack) * 2)
    Resume
'    Debug.Print maxstack
End Sub
'===========================================================================================================================
Public Sub QuickSortNonRecursive_i(ByRef SortArray(), ByRef r() As Long, Optional ByVal col = 1)
Dim i As Long, j As Long, lb As Long, ub As Long
Dim stack() As QuickStack, stackpos As Long, ppos As Long, pivot As Variant, swp, maxstack&
    On Error GoTo er
    lb = LBound(SortArray)
    ub = UBound(SortArray)
    For i = lb To ub
        r(i) = i
    Next
    ReDim stack(1 To 16)
    
    stackpos = 1

    stack(1).Low = lb
    stack(1).High = ub
    Do
        'Взять границы lb и ub текущего массива из стека.
        lb = stack(stackpos).Low
        ub = stack(stackpos).High
        stackpos = stackpos - 1
        Do
            'Шаг 1. Разделение по элементу pivot
            ppos = (lb + ub) \ 2
            i = lb: j = ub: pivot = SortArray(ppos, col)
            Do
                While SortArray(i, col) < pivot: i = i + 1: Wend
                While pivot < SortArray(j, col): j = j - 1: Wend
                If i > j Then Exit Do
'                If i <> j Then
                 swp = SortArray(i, col): SortArray(i, col) = SortArray(j, col): SortArray(j, col) = swp
                 swp = r(i): r(i) = r(j): r(j) = swp
'                End If
                i = i + 1
                j = j - 1
'                End If
           Loop While i <= j

            'Сейчас указатель i указывает на начало правого подмассива,
            'j - на конец левого lb ? j ? i ? ub.
            'Возможен случай, когда указатель i или j выходит за границу массива
            'Шаги 2, 3. Отправляем большую часть в стек  и двигаем lb,ub

            If i < ppos Then   'правая часть больше
                If i < ub Then
                    stackpos = stackpos + 1
                    stack(stackpos).Low = i
                    stack(stackpos).High = ub
                End If
                ub = j        'следующая итерация разделения будет работать с левой частью
            Else
                If j > lb Then
                    stackpos = stackpos + 1
                    stack(stackpos).Low = lb
                    stack(stackpos).High = j
                End If
                lb = i
            End If
'            If maxstack < stackpos Then maxstack = stackpos
        Loop While lb < ub
    Loop While stackpos
    Exit Sub
er: ReDim Preserve stack(1 To UBound(stack) * 2)
    Resume
'    Debug.Print maxstack
End Sub
'===========================================================================================================================
Public Sub QuickSortNonRecursive_2(ByRef SortArray(), Optional ByVal col = 1)
On Error Resume Next
If UBound(SortArray, 2) > 2 Then Exit Sub
Dim i As Long, j As Long, lb As Long, ub As Long, dc&
Dim stack() As QuickStack, stackpos As Long, ppos As Long, pivot As Variant, swp, maxstack&
    On Error GoTo er
    lb = LBound(SortArray)
    ub = UBound(SortArray)
    dc = UBound(SortArray, 2) + 1 - col
    ReDim stack(1 To 16)
    
    stackpos = 1

    stack(1).Low = lb
    stack(1).High = ub
    Do
        'Взять границы lb и ub текущего массива из стека.
        lb = stack(stackpos).Low
        ub = stack(stackpos).High
        stackpos = stackpos - 1
        Do
            'Шаг 1. Разделение по элементу pivot
            ppos = (lb + ub) \ 2
            i = lb: j = ub: pivot = SortArray(ppos, col)
            Do
                While SortArray(i, col) < pivot: i = i + 1: Wend
                While pivot < SortArray(j, col): j = j - 1: Wend
                If i > j Then Exit Do
'                If i <> j Then
                 swp = SortArray(i, col): SortArray(i, col) = SortArray(j, col): SortArray(j, col) = swp
                 swp = SortArray(i, dc): SortArray(i, dc) = SortArray(j, dc): SortArray(j, dc) = swp
'                End If
                i = i + 1
                j = j - 1
'                End If
           Loop While i <= j

            'Сейчас указатель i указывает на начало правого подмассива,
            'j - на конец левого lb ? j ? i ? ub.
            'Возможен случай, когда указатель i или j выходит за границу массива
            'Шаги 2, 3. Отправляем большую часть в стек  и двигаем lb,ub

            If i < ppos Then   'правая часть больше
                If i < ub Then
                    stackpos = stackpos + 1
                    stack(stackpos).Low = i
                    stack(stackpos).High = ub
                End If
                ub = j        'следующая итерация разделения будет работать с левой частью
            Else
                If j > lb Then
                    stackpos = stackpos + 1
                    stack(stackpos).Low = lb
                    stack(stackpos).High = j
                End If
                lb = i
            End If
'            If maxstack < stackpos Then maxstack = stackpos
        Loop While lb < ub
    Loop While stackpos
    Exit Sub
er: ReDim Preserve stack(1 To UBound(stack) * 2)
    Resume
'    Debug.Print maxstack
End Sub
'===========================================================================================================================
Sub sort_range(ByRef arr(), Optional ByVal col& = 1)
Dim nu&, nl&, i&, j&, rl&, ru&, i_arr&(), rez()
    On Error GoTo er1
    nu = UBound(arr, 2)
    nl = LBound(arr, 2)
    On Error GoTo er2
    rl = LBound(arr)
    ru = UBound(arr)
    If (nu - nl) = 1 Then
        Call QuickSortNonRecursive_2(arr, col)
    Else
    ReDim i_arr(rl To ru)
    rez = arr
    Call QuickSortNonRecursive_i(arr, i_arr, col)
    For i = rl To ru
        For j = nl To col - 1
            arr(i, j) = rez(i_arr(i), j)
        Next
        For j = col + 1 To nu
            arr(i, j) = rez(i_arr(i), j)
        Next
    Next
    End If
    Exit Sub
er1: Call QuickSortNonRecursive___(arr)
    Exit Sub
er2: MsgBox "Не массив"
End Sub

'Sub t()
'Dim arr(1 To 9, 1 To 3), r
'r = [a1:c9]
'For i = 1 To 9
'For j = 1 To 3
'arr(i, j) = r(i, j)
'Next
'Next
'Call sort_range(arr)
'[a1:c9] = arr
'End Sub

'Author: nerv
'E-mail: nerv-net@yandex.ru
'Last Update: 01/12/2011
'??????.??????: 41001156540584
'Тема на форуме: http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=8&TID=6998
'===============================================================================================================
Private Sub LiteSort(ByRef x())
Dim v, u&, d&, f%
If IsArray(x) Then
    f = LBound(x): d = f
    For u = f + 1 To UBound(x)
        If x(u) < x(d) Then
            v = x(d): x(d) = x(u): x(u) = v
            u = d - 1: d = u - 1: If u < f Then d = u: u = f
        End If
        d = d + 1
    Next
End If
End Sub
'Пример:
'Sub Example()
'Dim x()
'x = Array(9, 3, 8, 1, 6)
'LiteSort x()
'End Sub

'Сортировки двумерного массива
'Ссылка: http://excelvba.ru/code/SortArray
'===============================================================================================================
'Сортировка внутри VBA
'===============================================================================================================
Function CoolSort(SourceArr As Variant, ByVal N As Integer) As Variant
    ' сортировка двумерного массива по столбцу N
    If N > UBound(SourceArr, 2) Or N < LBound(SourceArr, 2) Then _
       MsgBox "Нет такого столбца в массиве!", vbCritical: Exit Function
    Dim Check As Boolean, iCount As Integer, jCount As Integer, nCount As Integer
    ReDim tmpArr(UBound(SourceArr, 2)) As Variant
    Do Until Check
        Check = True
        For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
            If Val(SourceArr(iCount, N)) > Val(SourceArr(iCount + 1, N)) Then
                For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
                    tmpArr(jCount) = SourceArr(iCount, jCount)
                    SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
                    SourceArr(iCount + 1, jCount) = tmpArr(jCount)
                    Check = False
                Next
            End If
        Next
    Loop
    CoolSort = SourceArr
End Function
'===============================================================================================================
'Сортировка на листе временной книги
'===============================================================================================================
Function SortArrayOnExcelWorksheet(ByRef arr) As Boolean
    On Error Resume Next: Err.Clear
    ' возвращает FALSE, если массив не поддается сортировке (не влазит на лист Excel)
    Application.ScreenUpdating = False
    Dim WB As Workbook, sh As Worksheet, ra As Range
    Set WB = Workbooks.Add(xlWBATWorksheet)
    If WB Is Nothing Then Exit Function
    Set sh = WB.Worksheets(1)
    Set ra = sh.Range("a1").Resize(UBound(arr, 1), UBound(arr, 2))
    ra.FormulaR1C1Local = arr
    If Err Then Debug.Print "Ошибка вставки массива для сортировки на лист": WB.Close False: Exit Function
 
    ra.Sort ra.Cells(1), 1, ra.Cells(2), , 1, ra.Cells(3), 1, xlNo ' сортировка массива

    If Err Then Debug.Print "Ошибка сортировки массива": WB.Close False: Exit Function
 
    arr = ra.FormulaR1C1Local
    SortArrayOnExcelWorksheet = True
    WB.Close False
End Function
'Пример: SortArrayOnExcelWorksheet arr

'===============================================================================================================
'Пузырьковая сортировка одномерного массива «arr»
'===============================================================================================================
Public Sub BubbleSort(ByRef arr)
    N = UBound(arr)
    For i = 0# To N - 1# Step 1
        For j = 0# To N - 2# - i Step 1
            If arr(j) > arr(j + 1#) Then
                tmp = arr(j)
                arr(j) = arr(j + 1#)
                arr(j + 1#) = tmp
            End If
        Next j
    Next i
End Sub
'===============================================================================================================
'то же, но внутри макроса
'===============================================================================================================
 For i& = LBound(arr) To UBound(arr) - 1
        For j& = LBound(arr) To UBound(arr) - 2 - i
            If arr(j) > arr(j + 1) Then tmp = arr(j): arr(j) = arr(j + 1): arr(j + 1) = tmp
        Next j
    Next i