使用VBA循环遍历每一列并从大到小排序

Posted 2023-03-27

【中文标题】使用VBA循环遍历每一列并从大到小排序

【英文标题】：Using VBA to loop through each column and sort from largest to smallest

【发布时间】：2022-01-01 19:14:37

【问题描述】：

我有一个由 excel 中的数字组成的数据集，包含 300 行和 2677 列，我希望遍历每一列并将它们从最大到最小排序。

我尝试修改下面的代码，但找不到循环遍历每一列并按从大到小排序的方法，谁能帮帮我吗？

    Range("I5").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("Sheet3").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet3").Sort.SortFields.Add2 Key:=Range("I5:I312" _
        ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet3").Sort
        .SetRange Range("I5:I312")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

【参考方案1】：

请尝试下一个代码。无需选择任何东西，选择只会消耗Excel资源，不会带来任何好处：

Sub SortColumns()
 Dim sh As Worksheet, lastCol As Long, i As Long
 Set sh = Worksheets("Sheet3")
 lastCol = 2677 'it can be calculated, if all existing columns should be sorted
 With Application 'a little optimization
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
 End With
 For i = 1 To lastCol
    sh.Range(sh.cells(5, i), sh.cells(5, i).End(xlDown)).Sort key1:=sh.cells(5, i), _
                  order1:=xlDescending, Header:=xlGuess, Orientation:=xlSortColumns
 Next i
 With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
 End With
End Sub

上面的代码假定排序范围内不存在空单元格。如果它们可能存在，则要排序的范围的最后一行应该以不同的方式计算。我保留了你的计算方式，但没有选择......

【参考方案2】：

对列进行降序排序

假设数据从包含此代码 (ThisWorkbook) 的工作簿的 Sheet3 的单元格 I5 开始。

Option Explicit

Sub SortColumnsDescending()
' Needs the 'RefColumn' function.
    Const ProcTitle As String = "Sort Columns Descending"
    
    Const wsName As String = "Sheet3"
    Const FirstCellAddress As String = "I5"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
    Dim lCell As Range
    Set lCell = ws.Cells(fCell.Row, ws.Columns.Count).End(xlToLeft)
    If lCell.Column < fCell.Column Then Exit Sub ' no data in header row range
    
    Dim hrrg As Range: Set hrrg = ws.Range(fCell, lCell) ' Header Row Range
    Dim frrg As Range: Set frrg = hrrg.Offset(1) ' Data First Row Range
    
    Application.ScreenUpdating = False
    
    Dim crg As Range ' Current Column Range
    Dim frCell As Range ' Current First Row Cell
    
    For Each frCell In frrg.Cells
        Set crg = RefColumn(frCell)
        If Not crg Is Nothing Then
            crg.Sort Key1:=crg, Order1:=xlDescending, Header:=xlNo
            Set crg = Nothing
        'Else ' no data in column range
        End If
    Next frCell
    
    Application.ScreenUpdating = True
    
    MsgBox "Columns sorted.", vbInformation, ProcTitle
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the one-column range from the first cell
'               of a range ('FirstCell') to the bottom-most non-empty cell
'               of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    If FirstCell Is Nothing Then Exit Function
    
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row + 1)
    End With

End Function