макросы в excel vba макросы сортировка диапазона

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

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

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

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)
Данные отсортированы по столбцам попеременно по возрастанию и убыванию

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