|
Сортировка двумерного массива на VB (VBA) |
Сортировка двумерного массива по нулевому столбцу
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
|
