Блог

Допустим, у меня есть Column A с некоторыми именами, за которыми следуют некоторые данные в Column B и Column C

Аналогично, у меня есть Column D с некоторыми именами, за которыми следуют некоторые данные в Column E и Column F .

Я хотел бы отсортировать строки в алфавитном порядке, сохраняя определенные столбцы (в данном случае A и D) в качестве их алфавитных ориентиров.

Позже, если я добавлю больше столбцов с большим количеством имен и данных, я бы хотел, чтобы функция / формула учитывала и это добавление в список.

Например:

     A    |    B    |    C    |    D    |    E    |    F
--------- --------- --------- --------- --------- ---------
 Albert  | ....... | ....... | Albert  | ....... | .......
 Charlie | ....... | ....... | Brian   | ....... | .......
         |         |         | David   | ....... | .......
  

Ожидаемый результат:

Альберт будет отображаться в той же строке, что и он повторяется в столбцах A и D. Брайан, Чарли и Дэвид будут отображаться в разных строках, поскольку их имя не повторяется в столбцах.

Есть ли способ сделать это?

     A    |    B    |    C    |    D    |    E    |    F
--------- --------- --------- --------- --------- ---------
 Albert  | ....... | ....... | Albert  | ....... | .......
         |         |         | Brian   | ....... | .......
 Charlie | ......  |......   |         |         |  
         |         |         | David   | ......  | ........
  

^^ Как вы заметили, в столбцах есть пустые строки, имя которых не отображается в списке.

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

 Option Explicit

Enum Nws                            ' Worksheet navigation: modify as appropriate
    ' 03 Mar 2019
    NwsFirstDataRow = 2             ' assuming 1 caption row: change as appropriate
    NwsSortClm1 = 1                 ' First name column to sort (1 = A)
    NwsSortClm2 = 4                 ' 4 = D
    NwsDataClms = 2                 ' number of data columns next to sort columns
End Enum

Sub SortNames()
    ' 03 Mar 2019

    Dim Wb As Workbook
    Dim Ws As Worksheet
    Dim Rng As Range
    Dim Arr(1) As Variant
    Dim R As Long, C As Long
    Dim i As Long
    Dim p As Long                           ' priority

    Application.ScreenUpdating = False
    Set Wb = ThisWorkbook                   ' change as appropriate: better to define Wb by name
    Set Ws = Worksheets("Sheet1")           ' change tab name as appropriate
    Ws.Copy After:=Ws
    Set Ws = ActiveSheet

    C = NwsSortClm1
    For i = 0 To 1                          ' corresponds to LBound(Arr) To UBound(Arr)
        With Ws
            Set Rng = .Range(.Cells(NwsFirstDataRow, C), _
                             .Cells(.Rows.Count, C   NwsDataClms).End(xlUp))
            With .Sort.SortFields
                .Clear
                .Add Key:=Rng.Columns(1), _
                     SortOn:=xlSortOnValues, _
                     Order:=xlAscending, _
                     DataOption:=xlSortNormal
            End With
            With .Sort
                .SetRange Rng
                .Header = False
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With

            Arr(i) = .Range(.Cells(NwsFirstDataRow, C), _
                             .Cells(.Rows.Count, C   NwsDataClms).End(xlUp)).Value
        End With
        C = NwsSortClm2
    Next i

    R = NwsFirstDataRow
    With Ws
        Do While Len(.Cells(R, NwsSortClm1).Value) And _
                 Len(.Cells(R, NwsSortClm2).Value) > 0
            p = StrComp(.Cells(R, NwsSortClm1).Value, _
                        .Cells(R, NwsSortClm2).Value, _
                        vbTextCompare)          ' not case sensitive !
            If p Then
                C = IIf(p < 0, NwsSortClm2, NwsSortClm1)
                Set Rng = .Range(.Cells(R, C), .Cells(R, C   NwsDataClms))
                Rng.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            End If
            R = R   1
        Loop
    End With
    Application.ScreenUpdating = True
End Sub
  

Код должен быть установлен в стандартном модуле code. Выполняемая процедура называется SortNames.

В целях тестирования создайте краткую версию ваших фактических данных, скажем, только от 5 до 8 строк. Создайте как минимум 3 версии этого тестового листа. Один с обоими столбцами сортировки одинаковой длины и по одному, где любой из столбцов сортировки длиннее. Обратите внимание, что должно иметь значение, содержит ли один столбец сортировки несколько записей в конце после завершения другого столбца сортировки. Не забудьте изменить название вкладки в Set Ws = Worksheets("Sheet1") перед запуском теста.

Добавьте этот код под двойной строкой Do While Len(.Cells(R, NwsSortClm1).Value) И _ Len(.Cells(R, NwsSortClm2).Value) > 0

 Debug.Print .Cells(R, NwsSortClm1).Value, Len(.Cells(R, NwsSortClm1).Value), _
                    .Cells(R, NwsSortClm2).Value, Len(.Cells(R, NwsSortClm2).Value)
  

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

Первая часть теста заключается в запуске кода выше точки останова. Создается копия листа и сортируются оба столбца. Вы сможете увидеть прогресс. Если есть какие-либо нарушения, необходимо выполнить дополнительные тесты для первой половины кода. Если нет, нажмите F5 еще раз. Каждый раз, когда вы нажимаете клавишу F5, выполняется один цикл кода, пока снова не будет достигнута точка останова. Вместо нажатия клавиши F5 вы можете нажать клавишу F8, чтобы запустить только одну строку кода и остановиться.

В цикле сначала будет выполнена Debug.Print инструкция. Вы можете навести курсор на R , и рядом с курсором будет показан номер текущей строки. Debug.Print Инструкции выведут текущие значения двух сортировочных столбцов и длину (количество символов) этих строк в ближайшее окно (под панелью code window). Код продолжает выполнение цикла, пока длина обеих ячеек больше нуля. Если по причине логической ошибки этого никогда не произойдет, цикл будет продолжаться до бесконечности, что не является намерением.

Чтобы остановить тест, удалить точку останова и нажать клавишу F5 или нажмите на малой площади над запуска команд в верхней командной строке, которая «сбрасывается» в качестве управления всплывающей подсказки текст.