Код ниже должен делать то, что вы хотите.Пожалуйста, попробуйте это.Обратите внимание, что вы можете установить основные параметры в перечислении в верхней части кода.
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
Код должен быть установлен через стандартный модуль кода.Процедура для запуска называется SortNames .
. В целях тестирования создайте краткую версию ваших фактических данных, скажем, только от 5 до 8 строк.Создайте как минимум 3 версии этого тестового листа.Один с обоими столбцами SortColumns равной длины и один с каждым из столбцов SortColumns длиннее.Обратите внимание, что должно иметь значение, имеет ли один SortColumn несколько записей в конце после завершения другого SortColumn.Не забудьте изменить имя вкладки в Set Ws = Worksheets("Sheet1") перед запуском теста.
Добавьте этот код ниже двойной строки Делать пока Len (.Cells (R, NwsSortClm1) .Value) И _ Len (.Cells(R, NwsSortClm2). Значение)> 0
Debug.Print .Cells(R, NwsSortClm1).Value, Len(.Cells(R, NwsSortClm1).Value), _
.Cells(R, NwsSortClm2).Value, Len(.Cells(R, NwsSortClm2).Value)
и добавить к нему точку останова.Чтобы добавить точку останова, нажмите на серую вертикальную полосу слева от окна кода.Там появятся две коричневые точки, а две линии будут выделены коричневым цветом.(Чтобы удалить точку останова, щелкните коричневые точки.) Теперь, когда вы поместите курсор в любом месте процедуры SortNames и нажмете F5, код будет работать до точки останова и остановится.Когда остановлено, все значения находятся в памяти, и вы можете запросить их, чтобы убедиться, что они соответствуют ожидаемым.
Первая часть теста заключается в запуске кода выше точки останова.Создает копию листа и сортирует оба столбца.Вы сможете увидеть прогресс.Если есть какие-либо нарушения, необходимо выполнить больше тестов для первой половины кода.Если нет, нажмите F5 еще раз.Каждый раз, когда вы нажимаете клавишу F5, один цикл кода будет выполняться, пока точка останова не будет достигнута снова.Вместо нажатия клавиши F5 вы можете нажать клавишу F8, чтобы запустить только одну строку кода и остановиться.
В цикле сначала будет выполняться инструкция Debug.Print.Вы можете навести курсор на R, и рядом с курсором будет показан номер текущей строки.Инструкции Debug.Print напечатают текущие значения двух SortColumns и длину (количество символов) этих строк в Immediate Window (под панелью окна кода).Код продолжает цикл, пока обе ячейки имеют значение, длина которого больше нуля.Если из-за логической ошибки этого не происходит, цикл будет продолжаться до бесконечности, что не является намерением.
Чтобы остановить тест, удалите точку останова и нажмите F5 или нажмите маленький квадрат над Выполнить команду в верхней панели команд, которая имеет «Сброс» в качестве текста подсказки.