Комфорт и автоматизация

Сортировка диапазона

Процедура для сортировки диапазона по любому количеству ключевых полей (строк или столбцов).

Входные параметры:

sh — лист, на котором происходит сортировка. Если это текущий лист, то укажите ActiveSheet.
fisrt_row, first_col — координаты первой ячейки (в верхнем левом углу диапазона)
last_row, last_col — координаты последней ячейки (в нижнем правом углу диапазона)

Header — содержит ли диапазон заголовки? False/True
Column — сортировать по столбцам (True) или по строкам (False)?

fields — массив, содержащий номера столбцов или строк (в стиле нумерации R1C1) по которым происходит сортировка. Порядок следования в массиве отражает приоритет ключевого поля — сначала сортируется по первому указанному в массиве полю, потом по второму, затем по третьему и т.д.
Игнорируются нули и нечисловые элементы, а также ключевые поля не содержащиеся в диапазоне. Дробные числа приводятся к целым.
Значения полей можно указывать отрицательными! В этом случае номер ключевого поля — модуль элемента, данное поле будет сортироваться по убыванию.

Public Sub SortRange(sh As Worksheet, _
                    first_row As Long, first_col As Long, _
                    last_row As Long, last_col As Long, _
                    Header As Boolean, _
                    Column As Boolean, _
                    ParamArray fields() As Variant)

    'Если больше 1-й строки,
    'если первый столбец не больше последнего
    'если строки/столбцы указаны корректно
    'то будем сортировать!
    If first_row < last_row And first_col <= last_col _
    And first_row > 0 And first_col > 0 _
    Then

        Dim c As Long 'Индекс в массиве
        Dim Order As Long 'По возрастанию или убыванию
        Dim Field As Variant 'Очередное ключевое поле
        Dim field_number As Byte 'Будем считать ключевые столбцы

        With sh

            .Activate 'Активизируем лист

            'Добавляем ключевые поля
            With .Sort.SortFields

                .Clear 'Очищаем от старых ключей

                'Пока ещё ключевых полей не добавляли
                field_number = 0

                For Each Field In fields(LBound(fields))

                    'Интересуют числа
                    If IsNumeric(Field) Then

                        Field = CLng(Field) 'Вдруг дробное

                        'Столбца/строки с номером 0 не бывает
                        If Field <> 0 Then

                            'Если ключ внутри сортируемого диапазона
                            If _
                            (Column And _
                            Abs(Field) >= first_col _
                            And Abs(Field) <= last_col) _
                            Or _
                            (Not Column _
                            And Abs(Field) >= first_row _
                            And Abs(Field) <= last_row) _
                            Then

                                '+1 ключевое поле
                                field_number = field_number + 1

                                'Направление сортировки
                                If Field > 0 Then
                                    'по возрастанию
                                    Order = xlAscending
                                Else
                                    'по убыванию
                                    Order = xlDescending
                                End If

                                'Очередной ключевой столбец...
                                If Column Then
                                    .Add _
                                    Key:=Range(Cells(first_row, _
                                               Abs(CLng(Field))), _
                                               Cells(last_row, _
                                               Abs(CLng(Field)))), _
                                    SortOn:=xlSortOnValues, _
                                    Order:=Order, _
                                    DataOption:=xlSortNormal
                                Else '... или строка
                                    .Add _
                                    Key:=Range(Cells(Abs(CLng(Field)), _
                                               first_col), _
                                               Cells(Abs(CLng(Field)), _
                                               last_col)), _
                                    SortOn:=xlSortOnValues, _
                                    Order:=Order, _
                                    DataOption:=xlSortNormal
                                End If

                            End If

                        End If

                    End If

                Next

            End With

            'Остальные настройки сортировки

            'Имеет смысл если есть ключевые поля
            If field_number > 0 Then

                With .Sort

                    'Диапазон
                    .SetRange Range(Cells(first_row, first_col), _
                                    Cells(last_row, last_col))

                    'Содержит ли диапазон заголовки?
                    If Header Then
                        .Header = xlYes 'Да
                    Else
                        .Header = xlNo 'Нет
                    End If

                    .MatchCase = False

                    'Сортируем по вертикали или горизонтали?
                    If Column Then
                        .Orientation = xlTopToBottom 'по столбцам
                    Else
                        .Orientation = xlLeftToRight 'по строкам
                    End If

                    .SortMethod = xlPinYin '"Китайский" метод

                    .Apply 'Сортируем!

                    'Очищаем параметры сортировки от ключевых полей
                    .SortFields.Clear

                End With

            End If

        End With

    End If

End Sub


Теперь покажу, как это чудовище применяется. Допустим, есть диапазон 15 на 15, заполненный в случайном порядке нулями и единицами. Нужно отсортировать его в первую очередь по первому столбцу диапазона, потом по второму, потом по третьему и так до самого последнего столбца.

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

Отсортируем по столбцам. Для этого заполним массив числами от 2 до 16 (номера столбцов на листе) и передадим этот массив в функцию. Укажем что диапазон с заголовками — таковые находятся в строке с нумерацией столбцов.

    Dim fields(1 To 15) As Long
    Dim i As Byte

    For i = 2 To 16
        fields(i) = i           
    Next
        
    Call SortRange(ActiveSheet, 1, 1, 16, 16, True, True, fields)


Как видите, в первом столбце диапазона (не забывайте, что первый столбец диапазона это не первый столбец листа) нули и единицы упорядочены. Это в свою очередь разбивает весь диапазон на два горизонтальных поддиапазона: обратите внимание в первой колонке на нули со 2-й строки по 6-ю и на единицы с 7-й по 16-ю. Оба поддиапазона фактически сортируются по следующему столбцу, в их пределах в следующем столбце тоже наблюдаем сортировку по нулям и единицам. Это в свою очередь разбивает поддиапазоны на ещё более мелкие поддиапазоны, которые сортируются по следующему столбцу и так далее. При этом по нумерации строк диапазона можно проверить, что в строках элементы находятся на своих местах.

Также стоит отметить, что хотя мы честно применили сортировку по всем 15 столбцам, на самом деле применилось только первые 7 или 8 из них. В дальнейшем сортировка по более старшим колонкам не имела значения, потому что там сортируемые поддиапазоны состояли всего из одной строки.

Отсортируем по строкам. Нам нужно отследить как перемешались столбцы, поэтому строку с нумерацией колонок мы как содержащую заголовки не указываем. А чтобы нам не путалась нумерация строк, мы не станем вносить первую колонку в сортируемый диапазон.

    Dim fields(1 To 15) As Long
    Dim i As Byte

    For i = 2 To 16
        fields(i) = i           
    Next
        
    Call SortRange(ActiveSheet, 1, 2, 16, 16, False, False, fields)


Итак, что мы видим, товарищи? Нули и единицы красиво выстраиваются в ряд, на каждой следующей строке словно в матрёшке начинаются вертикальные поддиапазоны поменьше, у которых в ряду тоже нули идут впереди единиц. Пользуясь нумерацией колонок, можете сравнить с оригиналом. Для проверки сравниваются нули/единицы не построчно, а «постолбцово».

Ну и на сладенькое покажу как сортировать по убыванию. Давайте отсортируем таким причудливым образом — если это нечётный по счёту столбец диапазона, то сортируем по убыванию, а если чётный — то по возрастанию.

    Dim fields(1 To 15) As Long
    Dim i As Byte
    Dim way As Integer

    way = 1
    For i = 2 To 16
        way = way * -1
        fields(i) = way * i
    Next
        
    Call SortRange(ActiveSheet, 1, 1, 16, 16, True, True, fields)


Те столбцы, которые нужно сортировать по убыванию, мы заносили в массив ключевиков со знаком минус. Если внимательно проверите результат, то увидите что с каждой следующей колонкой направление сортировки меняется на противоположное.