问Excel:对多个列进行单独排序

EN

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