Автор Тема: VBA Макросы: Сортировка vba-массива.  (Прочитано 703 раз)

Онлайн Администратор

  • Administrator
  • Сообщений: 1547
VBA Макросы: Сортировка vba-массива.
« : 22 Октябрь 2017, 22:26 »
Пояснения

В языке VBA нет готового инструмента для сортировки vba-массива и vba-программист должен сам написать код для сортировки.

В большинстве случаев достаточно использовать сортировку программы 'Excel': эксель сортирует быстро. Но в некоторых случаях не хочется использовать эксель или программы 'Excel' недостаточно:
1) например, надо отсортировать десять элементов. В этом случае не хочется создавать эксель-файл, вставлять в него данные и сортировать;
2) если в vba-массиве много строк: больше 1 млн. В этом случае эксель не подходит.

Кроме того сортировать умеет программа 'Word'.

Ниже используется принцип 'Быстрая сортировка' (Quick Sort, QuickSort, QSort). Microsoft или какая-либо другая известная организация не предоставляет код сортировки, поэтому я нашёл код в интернете, этот код сделан какими-то случайными программистами.


Коды сортировки

Текст сортируется с учётом регистра (больших / маленьких букв). Чтобы текст сортировался без учёта регистра, запишите в самый верх модуля (в котором находится код сортировки): Option Compare Text.

СОРТИРОВКА ОДНОМЕРНОГО МАССИВА ПО ВОЗРАСТАНИЮ
Sub Sort1_asc(arr(), Optional SortFragment As Boolean, Optional top As Long, Optional bot As Long)
   
    ' Сортировка одномерного массива по возрастанию.
   
    ' В массиве данные должны быть одного типа, чтобы была предсказуемая сортировка.
    ' Порядковый номер первого элемента может быть любой: процедура использует LBound.
   
    ' arr(): массив, который надо отсортировать.
    ' SortFragment: False - сортировать весь массив, True - сортировать фрагмент массива.
    ' top: с какой строки сортировать.
    ' bot: по какую строку сортировать.
   
    ' top и bot указывайте с учётом порядковой нумерации массива.
        ' Если порядковый номер первого элемента 0, то чтобы сортировать только первую и вторую ячейку,
        ' нужно указать 0, 1, а не 1, 2.
   
    '1. Если надо сортировать весь массив.
    If SortFragment = False Then
        top = LBound(arr)
        bot = UBound(arr)
    End If
   
    '2. Сортировка.
    QSort1_asc arr(), top, bot
   
End Sub
 
Private Sub QSort1_asc(arr(), ByVal top As Long, ByVal bot As Long)
   
    Dim t As Long, b As Long, MidItem, temp
   
    MidItem = arr((top + bot) \ 2)
    t = top: b = bot
   
    Do
        Do While arr(t) < MidItem: t = t + 1: Loop
        Do While arr(b) > MidItem: b = b - 1: Loop
        If t < b Then
            temp = arr(t): arr(t) = arr(b): arr(b) = temp
            t = t + 1: b = b - 1
        ElseIf t = b Then
            t = t + 1: b = b - 1
        End If
    Loop While t <= b
   
    If t < bot Then QSort1_asc arr(), t, bot
    If top < b Then QSort1_asc arr(), top, b
   
End Sub
СОРТИРОВКА ОДНОМЕРНОГО МАССИВА ПО УБЫВАНИЮ
Sub Sort1_desc(arr(), Optional SortFragment As Boolean, Optional top As Long, Optional bot As Long)
   
    ' Сортировка одномерного массива по убыванию.
   
    ' В массиве данные должны быть одного типа, чтобы была предсказуемая сортировка.
    ' Порядковый номер первого элемента может быть любой: процедура использует LBound.
   
    ' arr(): массив, который надо отсортировать.
    ' SortFragment: False - сортировать весь массив, True - сортировать фрагмент массива.
    ' top: с какой строки сортировать.
    ' bot: по какую строку сортировать.
   
    ' top и bot указывайте с учётом порядковой нумерации массива.
        ' Если порядковый номер первого элемента 0, то чтобы сортировать только первую и вторую ячейку,
        ' нужно указать 0, 1, а не 1, 2.
   
    '1. Если надо сортировать весь массив.
    If SortFragment = False Then
        top = LBound(arr)
        bot = UBound(arr)
    End If
   
    '2. Сортировка.
    QSort1_desc arr(), top, bot
   
End Sub
 
Private Sub QSort1_desc(arr(), ByVal top As Long, ByVal bot As Long)
   
    Dim t As Long, b As Long, MidItem, temp
   
    MidItem = arr((top + bot) \ 2)
    t = top: b = bot
   
    Do
        Do While arr(t) > MidItem: t = t + 1: Loop
        Do While arr(b) < MidItem: b = b - 1: Loop
        If t < b Then
            temp = arr(t): arr(t) = arr(b): arr(b) = temp
            t = t + 1: b = b - 1
        ElseIf t = b Then
            t = t + 1: b = b - 1
        End If
    Loop While t <= b
   
    If t < bot Then QSort1_desc arr(), t, bot
    If top < b Then QSort1_desc arr(), top, b
   
End Sub
СОРТИРОВКА ДВУМЕРНОГО МАССИВА ПО ВОЗРАСТАНИЮ
Sub Sort2_asc(arr(), col As Long, Optional SortFragment As Boolean, Optional top As Long, Optional bot As Long)
   
    ' Сортировка двумерного массива по возрастанию.
   
    ' В столбце, по которому сортировка, данные должны быть одного типа, чтобы была предсказуемая сортировка.
    ' Порядковый номер первой строки и столбца может быть любой: процедура использует LBound.
   
    ' arr(): массив, который надо отсортировать.
    ' col: номер столбца, по которому надо сортировать. Номер столбца относительно
        ' массива: если порядковый номер первого столбца 0, значит для сортировки по
        ' первому столбцу нужно указывать 0, а не 1.
    ' SortFragment: False - сортировать весь массив, True - сортировать фрагмент массива.
    ' top: с какой строки сортировать.
    ' bot: по какую строку сортировать.
   
    ' top и bot указывайте с учётом порядковой нумерации массива.
        ' Если порядковый номер первой строки 0, то чтобы сортировать только первую и вторую строку,
        ' нужно указать 0, 1, а не 1, 2.
   
    Dim temp(), lb2 As Long, ub2 As Long
   
   
    '1. Если надо сортировать весь массив.
    If SortFragment = False Then
        top = LBound(arr, 1)
        bot = UBound(arr, 1)
    End If
   
    '2. Создание элементов. Делается здесь, а не внутри процедуры сортировки, чтобы ускорить.
    lb2 = LBound(arr, 2)
    ub2 = UBound(arr, 2)
    ReDim temp(lb2 To ub2)
   
    '3. Сортировка.
    QSort2_asc arr(), col, top, bot, temp(), lb2, ub2
   
End Sub
 
Private Sub QSort2_asc(arr(), c As Long, ByVal top As Long, ByVal bot As Long, temp(), lb2 As Long, ub2 As Long)
   
    Dim t As Long, b As Long, MidItem, j As Long
   
    MidItem = arr((top + bot) \ 2, c)
    t = top: b = bot
   
    Do
        Do While arr(t, c) < MidItem: t = t + 1: Loop
        Do While arr(b, c) > MidItem: b = b - 1: Loop
        If t < b Then
            For j = lb2 To ub2: temp(j) = arr(t, j): Next j
            For j = lb2 To ub2: arr(t, j) = arr(b, j): Next j
            For j = lb2 To ub2: arr(b, j) = temp(j): Next j
            t = t + 1: b = b - 1
        ElseIf t = b Then
            t = t + 1: b = b - 1
        End If
    Loop While t <= b
   
    If t < bot Then QSort2_asc arr(), c, t, bot, temp(), lb2, ub2
    If top < b Then QSort2_asc arr(), c, top, b, temp(), lb2, ub2
   
End Sub
СОРТИРОВКА ДВУМЕРНОГО МАССИВА ПО УБЫВАНИЮ
Sub Sort2_desc(arr(), col As Long, Optional SortFragment As Boolean, Optional top As Long, Optional bot As Long)
   
    ' Сортировка двумерного массива по убыванию.
   
    ' В столбце, по которому сортировка, данные должны быть одного типа, чтобы была предсказуемая сортировка.
    ' Порядковый номер первой строки и столбца может быть любой: процедура использует LBound.
   
    ' arr(): массив, который надо отсортировать.
    ' col: номер столбца, по которому надо сортировать. Номер столбца относительно
        ' массива: если порядковый номер первого столбца 0, значит для сортировки по
        ' первому столбцу нужно указывать 0, а не 1.
    ' SortFragment: False - сортировать весь массив, True - сортировать фрагмент массива.
    ' top: с какой строки сортировать.
    ' bot: по какую строку сортировать.
   
    ' top и bot указывайте с учётом порядковой нумерации массива.
        ' Если порядковый номер первой строки 0, то чтобы сортировать только первую и вторую строку,
        ' нужно указать 0, 1, а не 1, 2.
   
    Dim temp(), lb2 As Long, ub2 As Long
   
   
    '1. Если надо сортировать весь массив.
    If SortFragment = False Then
        top = LBound(arr, 1)
        bot = UBound(arr, 1)
    End If
   
    '2. Создание элементов. Делается здесь, а не внутри процедуры сортировки, чтобы ускорить.
    lb2 = LBound(arr, 2)
    ub2 = UBound(arr, 2)
    ReDim temp(lb2 To ub2)
   
    '3. Сортировка.
    QSort2_desc arr(), col, top, bot, temp(), lb2, ub2
   
End Sub
 
Private Sub QSort2_desc(arr(), c As Long, ByVal top As Long, ByVal bot As Long, temp(), lb2 As Long, ub2 As Long)
   
    Dim t As Long, b As Long, MidItem, j As Long
   
    MidItem = arr((top + bot) \ 2, c)
    t = top: b = bot
   
    Do
        Do While arr(t, c) > MidItem: t = t + 1: Loop
        Do While arr(b, c) < MidItem: b = b - 1: Loop
        If t < b Then
            For j = lb2 To ub2: temp(j) = arr(t, j): Next j
            For j = lb2 To ub2: arr(t, j) = arr(b, j): Next j
            For j = lb2 To ub2: arr(b, j) = temp(j): Next j
            t = t + 1: b = b - 1
        ElseIf t = b Then
            t = t + 1: b = b - 1
        End If
    Loop While t <= b
   
    If t < bot Then QSort2_desc arr(), c, t, bot, temp(), lb2, ub2
    If top < b Then QSort2_desc arr(), c, top, b, temp(), lb2, ub2
   
End Sub


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

СОРТИРОВКА ВСЕГО ОДНОМЕРНОГО МАССИВА ПО ВОЗРАСТАНИЮ
Sub Макрос()

    Dim arr()
   
    '1. Запись в массив данных.
    arr() = Array(10, 5, 3, 1)
    '2. Сортировка по возрастанию.
    Sort1_asc arr()

End Sub
СОРТИРОВКА ТОЛЬКО ДВУХ ЭЛЕМЕНТОВ ОДНОМЕРНОГО МАССИВА ПО ВОЗРАСТАНИЮ
Sub Макрос()

    Dim arr()
   
    '1. Создание ячеек в массиве и запись в массив данных.
    ReDim arr(1 To 5)
    arr(1) = 10
    arr(2) = 8
    arr(3) = 5
    arr(4) = 3
    arr(5) = 1

    '2. Сортировка по возрастанию второго и третьего элемента.
        ' Остальные элементы останутся на своих местах.
    Sort1_asc arr(), True, 2, 3

End Sub
СОРТИРОВКА ВСЕХ СТРОК ДВУМЕРНОГО МАССИВА ПО ВОЗРАСТАНИЮ
Sub Макрос()

    Dim arr()
   
    '1. Создание ячеек в массиве и запись в массив данных.
    ReDim arr(1 To 5, 1 To 1)
    arr(1, 1) = 10
    arr(2, 1) = 8
    arr(3, 1) = 5
    arr(4, 1) = 3
    arr(5, 1) = 1
   
    '2. Сортировка по возрастанию по первому столбцу.
    Sort2_asc arr(), 1

End Sub


Возможные проблемы при сортировке

В комментариях к коду об этих особенностях написано, но предполагаю, что кто-то может не обратить внимания на комментарии.

Указание диапазона сортировки. У vba-массивов порядковый номер первой ячейки (строки) может быть любым, хоть отрицательным. В некоторых случаях, по умолчанию VBA назначает первому элементу (строке) порядковый номер 0. Поэтому в этом случае, если вам надо сортировать ячейки 2 и 3, нужно указать 1 и 2.

Такое может быть при использовании функций: Split, Array. Возможно и в других случаях.

Также такое может быть при использовании ReDim без указания порядкового номера для первого элемента: ReDim arr(1). В этом случае будет создано два элемента, а не 1, порядковый номер первого элемента будет 0, второго 1. Чтобы порядковый номер первого элемента был 1, нужно записать так: ReDim arr(1 To 1). Или можно вверху модуля записать: Option Base 1.

Указание столбца сортировки в двумерном массиве. У vba-массивов порядковый номер первого столбца может быть любым, хоть отрицательным. В некоторых случаях, по умолчанию VBA назначает первому столбцу порядковый номер 0. Поэтому в этом случае, если вам надо сортировать по столбцу 1, нужно указать 0.

Такое может быть при использовании ReDim без указания порядкового номера для первого столбца: ReDim arr(1, 1). В этом случае будет создано два столбца, а не 1, порядковый номер первого столбца будет 0, второго 1. Чтобы порядковый номер первого столбца был 1, нужно записать так: ReDim arr(1 To 1, 1 To 1). Или можно вверху модуля записать: Option Base 1.

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