对四列

Question

我有以下表格和代码，目前无法正常工作。我想要的是排序

1. 第一栏F，
2. 然后是B栏，
3. 然后是D栏，
4. 和最后一栏E

A列中的数据：F是一个数据集，因此我需要对整个数据集进行上述排序（F，B，D，E），而不是仅仅相继取一列。

另外，我在第1行中有一些数据，所以我不能只选择“整个”列，而是需要在特定的“数据字段”中进行排序。

请建议我如何添加第四个排序，以便应用上述排名。

谢谢！

Private Sub Remove_Dubs_IndBB()

Dim i As Long
Dim data As Integer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

data = Range("A2", Range("A" & Rows.Count).End(xlUp)).Count

Call Sum_IF
SendKeys ("{ESC}")

 With Range("A2", Range("F" & Rows.Count).End(xlUp))

 .Sort Key1:=Cells(1, 6), Order1:=xlDescending, _
 Header:=xlNo

    For i = 1 To data
        If (VBA.Date - Cells(i, 4)) / 365 > 5 Then
            Range(Cells(i, 1), Cells(i, 6)).ClearContents
        End If
        If (Cells(i, 5) - VBA.Date) / 365 < 1.25 Then
            Range(Cells(i, 1), Cells(i, 6)).ClearContents
        End If
     Next i

Range("A2", Range("F" & Rows.Count).End(xlUp).Address).Select
    Selection.Sort Key1:=Columns(6), Order1:=xlDescending, _
    Header:=xlNo

    Selection.Sort Key1:=Columns(2), Order1:=xlDescending _
    , Key2:=Columns(4), Order2:=xlDescending _
    , Key3:=Columns(5), Order3:=xlDescending _
    , Header:=xlNo


Range("A2", Range("F" & Rows.Count).End(xlUp)).RemoveDuplicates (3),        Header:=xlNo

 End With

 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic

 End Sub

 Sub Sum_IF()

 Dim i As Long
 Dim data As Integer

data = Range("A2", Range("A" & Rows.Count).End(xlUp)).Count

 With Range("A2", Range("F" & data))
 For i = 1 To data
    .Cells(i, 6).FormulaR1C1 = "=SUMIF(R2C3:R[" & data & "]C3, RC[-3], R2C2:R[" & data & "]C2)"
    .Cells(i, 6).Copy
    .Cells(i, 6).PasteSpecial xlPasteValues
Next i
 End With

 End Sub

Answer 1

好的，所以答案是按F列排序，然后对F中的所有具有相同值的范围排序，按剩余的三个标准对数据进行排序。

以下Sub将对四列

中的数据进行排序

Sub SortFourCols()
    Dim RowCounter As Long, RowDepth As Long, i As Long
    Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
    Dim DataRows As Long: DataRows = Range("A1", Range("A" & Rows.Count).End(xlUp)).Count
    Dim MatchRange As Range

    ' F,B,D,E
    With ws.Sort
        .Header = xlNo
        .SortFields.Clear
        .SortFields.Add Key:=Range("F:F"), SortOn:=xlSortOnValues, Order:=xlAscending
        .SetRange Range(Cells(2, 1), Cells(DataRows, 6))
        .Apply
        .SortFields.Clear
        .SortFields.Add Key:=Range("B:B"), Order:=xlAscending
        .SortFields.Add Key:=Range("D:D"), Order:=xlAscending
        .SortFields.Add Key:=Range("E:E"), Order:=xlAscending
    End With
    Set MatchRange = ws.Range(Cells(2, 6), Cells(DataRows, 6))
    With ws
        For i = 2 To DataRows
            RowDepth = Application.WorksheetFunction.CountIf(MatchRange, .Cells(i, 6).Value)
            If RowDepth > 1 Then
                With .Sort
                    .SetRange Range(Cells(i, 1), Cells(i + RowDepth - 1, 6))
                    .Apply
                End With
            End If
            i = i + RowDepth - 1
            If i > DataRows Then Exit For
        Next i
    End With
End Sub

********* EDIT *********

显然，您可以使用3个以上的键（不同之处可能在于使用范围排序与设置工作表排序选项并在范围内使用它们）。我不知道Office的版本是否会对此产生影响;但它简化了很多事情：

Sub SortFourCols()
    Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
    Dim DataRows As Long: DataRows = ws.Range("A1", Range("A" & Rows.Count).End(xlUp)).Count

    ' F,B,D,E
    With ws.Sort
        .Header = xlYes
        .SortFields.Clear
        .SetRange Range(Cells(1, 1), Cells(DataRows, 6))
        .SortFields.Add Key:=Range("F:F"), Order:=xlAscending
        .SortFields.Add Key:=Range("B:B"), Order:=xlAscending
        .SortFields.Add Key:=Range("D:D"), Order:=xlAscending
        .SortFields.Add Key:=Range("E:E"), Order:=xlAscending
        .Apply
        .SortFields.Clear
    End With
End Sub