Сортировка двумерного массива на 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) - i
            If arr(j) > arr(j + 1) Then Tmp = arr(j): arr(j) = arr(j + 1): arr(j + 1) = Tmp
        Next j
    Next i

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Игорь, предлагаю на Ваш суд такой вариант сортировки (через временный лист). При сортировке 400к+ текстовых значений время сортировки составляет несколько секунд (для меньших объемов возможно и не требуется такой подход). На вход подается двумерный массив с двумя столбцами, сортировка по первому столбцу, заголовки - опционально.
P.S. табуляция с отступами в коде пропали во время вставки кода на данной страничке... так что извиняйте за такое форматирование

Sub SortValue(ByRef rInitArr As Variant)
Dim sTMPSh$
sTMPSh = "Sortir"
On Error Resume Next
If Sheets(sTMPSh) Is Nothing Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Select
Sheets(Sheets.Count).Name = sTMPSh
Else
With Sheets(sTMPSh)
.Select
.Cells.ClearContents
End With
End If
On Error GoTo 0
Application.DisplayAlerts = False
Application.EnableEvents = False
With ActiveWorkbook.Worksheets(sTMPSh)
.Range(.Cells(2, 1), .Cells(UBound(rInitArr), 2)) = rInitArr
.Cells(1, 1) = "Сортируемый столбец"
.Cells(1, 2) = "Второй строки"
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Cells(1, 1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SetRange Range(Cells(1, 1), Cells(UBound(rInitArr), 2))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
rInitArr = .Range(Cells(2, 1), Cells(UBound(rInitArr), 2))
.Delete
End With
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

При сортировке "скромного" массива на 400к+ строк через предложеннух функцию (первая по счету) комп ушел в "несознанку" на несколько десятков минут (терпение закончилось раньше)... Если-то же самое выполнить средствами Worksheet (т.е. стандартный фильтр и в нем сортировка) - сортировка занимает около 2,5 минут (без учета выгрузки содержимого массива на временный лист (код примерно такой range(cells(1,1), cells(ubound(sourcearr), 2)) = sourcearr (цикл по строкам массива в данном случае не требуется)) и повторного считывания в массив).
В связи с чем вопрос: при каких размерах массивов есть смысл использовать тот или иной метод сортировки (безусловно, если есть какая то статистика)? Значения текстовые, массив двумерный.

Привет!

Спасибо за труды!

nCount не нужен.

Вместо
ReDim tmpArr(UBound(SourceArr, 2)) As Variant
достаточно
dim vTmp as Variant

Спасибо за уточнение, Михаил!

А только мне кажется, что в пузырьке строка
For j& = LBound(arr) To UBound(arr) - 2 - i
должна быть
For j& = LBound(arr) To UBound(arr) - 1 - i
?? Пять лет прошло так-то...

Алексей, очень помогли, спасибо!

Спасибо!

Просто, большое человеческое спасибо! Двумерка заработала!

Здравствуйте,а как применить данную программу,только если в ячейках сортированной матрицы были квадраты чисел?

Искал алгоритм, набрел на этот, но написал свой.
Первый алгоритм неэффективный. Очень много перестановок, а это самая долгая операция.
Предлагаю более простой и сортировка по любому количеству столбцов в любом порядке. Кому надо направление сортировки и произвольные границы, можете доработать сами. Последняя строка массива передается, потому что массив может быть заполнен не весь

Private Sub SortArray(myArray, countRows, ParamArray sortC())
Dim cRA%, cR%, minR%, cS%, cE%, countC%, tempV
..For cRA = 0 To countRows - 1
....minR = cRA
....For cR = cRA + 1 To countRows - 1
......For cS = 0 To UBound(sortC)
........If myArray(cR, sortC(cS)) <> myArray(minR, sortC(cS)) Then
..........If myArray(cR, sortC(cS)) < myArray(minR, sortC(cS)) Then minR = cR
..........Exit For
........End If
......Next
....Next
....If minR > cRA Then
......'меняем местами строки
......For cC = 0 To UBound(myArray, 2)
........tempV = myArray(cRA, cC)
........myArray(cRA, cC) = myArray(minR, cC)
........myArray(minR, cC) = tempV
......Next
....End If
..Next
End Sub

Вызов: SortArray Ar, 5, 2, 0, 1
Ar - массив, 5 - последняя строка, 2, 0, 1 - столбцы для сортировки

Как записать массив на лист я указал в комментариях http://excelvba.ru/code/Array2worksheet#comment-2866
Для сортировки двумерного массива по нужному столбцу нужна другая функция (если нужно, напишу).

Огромное спасибо за помощь!

Алина, если бы вы пролистали статью немного вниз,
то в комментах нашли бы ответ на вопрос, как отсортировать текст:
http://excelvba.ru/code/SortArray#comment-729

Пример использования

sub макрос()
  arr = range("a1:d10").value ' считываем матрицу (массив) с листа Excel 
  CoolSort arr, 3 ' сортируем по 3 столбцу
  range("a1:d10").value = arr ' записываем результат обратно на лист
end sub

Можно ли использовать второй макрос (где можно выбрать столбец) для сортировки двумерного массива по 3-му столбцу, если в столбце не числа, а текст, т.е. упорядочить по алфавиту?
И еще, подскажите, (конечно, глупый вопрос, но если не спрашивать, то как тогда научиться?!) как эту функцию вызвать и как полученную отсортированную матрицу записать на лист Excel?
Заранее спасибо!

Очередная, применённая мною, функция из раздела "Обработка массивов".
Уже и не помню пятая или шестая, в течение достаточно короткого времени.
Все работает отлично.
Спасибо Вам за Ваш труд!

На самом деле не самая быстрая сортировка получается, особенна разница видна при >1000 строк и больше 3х столбцов. Я бы предложил Quick sort использовать. Примерно так:
где a() это массив, который нужно отсортировать (двумерный), n - это номер стобца по которому сортирует, а low и high это начальная и конечная строка диапазона, который нужно отсортировать, если нужно отсортировать весь массив, то естественно - это начало и конец массива

Public Sub aQSort2(ByRef a() As Variant, ByVal n As Integer, ByRef low As Long, ByRef high As Long)
Dim i As Long, j As Long, k As Long
Dim m As Variant, wsp As Variant
i = low
j = high
m = a(Round((i + j) \ 2), n)
Do Until i > j
Do While a(i, n) < m
i = i + 1
Loop
Do While a(j, n) > m
j = j - 1
Loop
If (i <= j) Then
For k = LBound(a, 2) To UBound(a, 2)
wsp = a(i, k)
a(i, k) = a(j, k)
a(j, k) = wsp
Next k
i = i + 1
j = j - 1
End If
Loop
If (low < j) Then aQSort2 a(), n, low, j
If (i < high) Then aQSort2 a(), n, i, high
End Sub

Справлюсь, конечно, но дёлать не буду -не люблю студентов-халявщиков, которые пытаются взять меня "на слабо"

В матрице С(8,6) в каждом столбце расставить элементы по возрастанию и найти значение минимального элемента матрицы.
А сможете для этого программу написать на языке VBA.

спасибо! заодно новый метод вывода освоила)) написала вам в ICQ

Вот так будет правильно:

Sub v7zad16()
    Dim a() As Integer, N As Integer, i As Integer, j As Integer
    N = Val(InputBox("vved n"))
 
    ReDim a(1 To N, 1 To N + 1)
    Randomize Timer
 
    For i = 1 To N
        For j = 1 To N
            a(i, j) = Rnd * 10
            a(i, N + 1) = a(i, N + 1) + a(i, j)
        Next j
    Next i
 
    Cells.Clear    ' очистка ячеек

    Cells(1, 1) = "исходная матрица"
    Cells(2, 1).Resize(N, N).Value = a    ' вывод на лист

    CoolSort a, N + 1    ' сортируем
    Cells(N + 3, 1) = "сортированнная матрица"
    Cells(N + 4, 1).Resize(N, N + 1).Value = a    ' вывод на лист
End Sub

Результат:

результат сортировки двумерного массива

При помощи датчика случайных чисел заполнить действительную квадратную матрицу A порядка N (N ввести с клавиатуры). Переставить строки матрицы так, чтобы сумма элементов строк была возрастающая. Вывести сумму элементов строк, а также матрицу A до и после преобразования.

Sub v7zad16()
 
Dim a() As Integer, N As Integer, b() As Integer, t As Double, jmax As Long
Dim i As Integer, j As Integer, k As Integer, kk As Integer
Sheets("Лист16").Select: Cells.Clear 
N = Val(InputBox("vved n"))
ReDim a(N, N + 1) 
ReDim b(N, N + 1)
Randomize Timer 
For i = 1 To N 
For j = 1 To N  
  a(i, j) = Rnd * 10
  Cells(i, j) = a(i, j)
  a(i, N + 1) = a(i, N + 1) + a(i, j) 
Next j
 Cells(i, N + 1) = a(i, N + 1) 
Next i
 
 
b(N, N + 1)=CoolSort (a(n,n+1),n+1)
 
End Sub

если так, то ругается

как его хоть вызвать то

да эт понятно. у меня это всё равно потом пересекается. а метод Sort мне не понравился. мягко говоря.
за сайт спасибо.

Степан, этот макрос предназначен для сортировки МАССИВА, а не ДИАПАЗОНА ЯЧЕЕК.
Чтобы отсортировать диапазон ячеек - достаточно макроса из одной строки
(метод Sort объекта Range)

Полезный макрос. Спасибо. Жаль только, что формулы все херит.

Можно сортировать и как текст.
Для этого замените строку

If Val(SourceArr(iCount, N)) > Val(SourceArr(iCount + 1, N)) Then

на
If cstr(SourceArr(iCount, N)) > cstr(SourceArr(iCount + 1, N)) Then

Жаль, что сортирует только числовые данные, а работает быстро :)

Спасибо Вам огромнейшее! :)

Добавил в текст статьи вариант функции с изменяемым номером столбца для сортировки

Здравствуйте. А возможно применить сортировку массива по 2-му, третьему столбцу? Какой параметр следует изменить? Спасибо.

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _  __   ____          _     _____   _   _ 
| |/ / / ___| _ __ | |_ |___ | | | | |
| ' / | | | '__| | __| / / | | | |
| . \ | |___ | | | |_ / / | |_| |
|_|\_\ \____| |_| \__| /_/ \___/
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.