'Сортировка двумерного массива по нулевому столбцу

Public Function CoolSort(SourceArr As Variant) As Variant

' сортировка двумерного массива по нулевому столбцу

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, 0)) > Val(SourceArr(iCount + 1, 0)) 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 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

'Сортировка двумерного массива на листе Excel, по первым 3 столбцам по возрастанию _
(создаётся временная книга из 1 листа для сортировки массива, после сортировки книга закрывается)

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

'Ну и обычная пузырьковая сортировка одномерного массива

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

'то же самое, но внутри макроса (arr - одномерный массив)

    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