如何在MS Excel中跨列按字母顺序对行进行排序？

Question

Let's say I have Column A with some names followed by some data in Column B and Column C

Similarly, I have Column D with some names followed by some data in Column E and Column F .

I would like to sort the rows in alphabetical order keeping certain columns (in this case A and D) as their alphabetical guides.

Later on, if I add more columns with more names and data, I would want the function/formula to account for that addition to the list as well.

For Example:

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

Expected Result:

Albert would show in the same row as he is repeated in columns A and D. Brian, Charlie and David would show in different rows as their name is not repeated across columns.

Is there a way to do it?

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

^^ As you notice there are blank rows in the columns in which a name isn't shown in the list.

Answer 1

The code below should do what you want. Please try it. Note that you can set the main parameters in the enumeration at the top of the code.

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

The code should be installed om a standard code module. The procedure to run is called SortNames .

For testing purposes create a short version of your actual data, say 5 to 8 rows only. Create at least 3 versions of this test sheet. One with both SortColumns of equal length and one each where either of the SortColumns is longer. Observe that it should make a difference whether one SortColumn has several entries at the end after the other SortColumn is complete. Remember to change the tab name in Set Ws = Worksheets("Sheet1") before test runs.

Add this code below the double line Do While Len(.Cells(R, NwsSortClm1).Value) And _ 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)

and add a break point to it. To add a break point click on the grey, vertical bar to the left of the code window. Two brown points will appear there and the two lines will be highlighted brown. (To remove the break point click the brown points.) Now, when you place the cursor anywhere in the procedure SortNames and press F5 the code will run up to the break point and stop. When stopped all values are in memory and you can query them to make sure they are as expected.

The first part of the test is to run the code above the break point. It creates a copy of the sheet and sorts both columns. You will be able to see the progress. If there is any irregularity so far more tests have to be done on the first half of the code. If not, press F5 again. Each time you press F5 one loop of the code will run until the break point is hit again. Instead of pressing F5 you can press F8 to run only one line of code and stop.

In the loop the Debug.Print instruction will be carried out first. You can point the cursor at R and the current row number will be shown next to the cursor. The Debug.Print instructions will print the current values of the two SortColumns and the length (number of characters) of these strings to the Immediate Window (below the code window panel). The code continues looping while both cells have a value the length of which is greater than zero. If, by reason of a logical error, this never happens the loop would continue ad infinitum which isn't the intention.

To stop the test, remove the break point and press F5 or press the little square above the Run command in the top command bar which has "Reset" as a control tip text.