Excel：分别对多列进行排序

Question

我有一个类似 的 Excel 表格 - 所有数据都是数字数据。实际工作表实际上有更多的行和列。

https://i.imgur.com/E2HEdXF.png

我想从这些数据中得到的结果是这样的 - 对于每一年，我想根据年份的数字数据对 A 和 F 进行排序。所以不是一种，而是每年一种。

我认为没有一种简单的方法可以做到这一点，所以我想了两种可能的方法

1. 我将数据导出到某个数据库，然后使用 SQL 查询来获得我想要的输出 - 我假设必须有一些数据库允许您导入 Excel 数据。

或

1. 编写一个 VBA 程序，它执行以下操作 - 将 D 列和 E 列复制到另一个地方并根据 E 列排序。然后将 D 列和 F 列复制到另一个地方并根据 F 列排序等等。

我从未做过 VBA，但我是程序员，所以我认为这样做不会很麻烦。

但是，我想知道是否有其他更简单的方法可以做到这一点，或者如果没有，以上两种方法中哪一种更好。

Answer 1

复制和排序

• 下面将把D:G列中的数据作为由第一列和每一列组成的列对复制到包含此代码的工作簿的新创建工作表的列A:B，最后按列@降序排序987654325@。已经存在的要创建的工作表之前将被删除。
• 调整常量部分中的值。

Option Explicit

Sub copyAndSort()
    
    Const sName As String = "Sheet1"
    Const sFirst As String = "D1"
    Const yCols As String = "E:G"
    
    Const dFirst As String = "A1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Dim srg As Range
    Dim yrg As Range
    Dim rCount As Long
    Dim cCount As Long
    
    With sws.Range(sFirst)
        Dim rOff As Long: rOff = .Row - 1
        Dim sCell As Range
        Set sCell = .Resize(.Worksheet.Rows.Count - rOff) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If sCell Is Nothing Then Exit Sub
        rCount = sCell.Row - rOff
        Set srg = .Resize(rCount)
        Set yrg = .Worksheet.Columns(yCols).Rows(.Row).Resize(rCount)
        cCount = yrg.Columns.Count
    End With
    
    Dim sData As Variant: sData = srg.Value
    ReDim Preserve sData(1 To rCount, 1 To 2)
    Dim yData As Variant: yData = yrg.Value
    
    Dim Result As Variant: ReDim Result(1 To cCount)
    
    Dim c As Long, r As Long
    
    For c = 1 To cCount
        Result(c) = sData
        For r = 1 To rCount
            Result(c)(r, 2) = yData(r, c)
        Next r
    Next c
    Erase yData
    Erase sData
    
    Dim dws As Worksheet
    Dim drg As Range
    Dim dName As String
    
    Application.ScreenUpdating = False
    
    For c = 1 To cCount
        dName = Result(c)(1, 2)
        On Error Resume Next
        Set dws = Nothing
        Set dws = wb.Worksheets(dName)
        On Error GoTo 0
        If Not dws Is Nothing Then
            Application.DisplayAlerts = False
            dws.Delete
            Application.DisplayAlerts = True
        End If
        Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
        dws.Name = dName
        Set drg = dws.Range(dFirst).Resize(rCount, 2)
        drg.Value = Result(c)
        drg.Sort Key1:=drg.Cells(2), Order1:=xlDescending, Header:=xlYes
    Next c

    wb.Save
        
    Application.ScreenUpdating = True
        
End Sub