一个VBA 支持多列（可大于4列）排序的函数

 '************************************************************** '============================================================== '- Name:SortSheet '- Author:Chen '- Last Change: 09-1-19 by Chen '- Input parameters: ' *Sh : the sheet name to be sorted ' *DataCols : array contains the columns to be copied to tempsheet ' *keysCols : array contains the columns of keys ' *keyDigital : array contains the information that whether the key is digital ' *MainCol : the ID column which can identify one record ' *[StartRow] : the row data start from '- Output parameter: ' *temp sheet name '- Preconditions: ' *Sh exist '- functional description of sub: ' -create a temp sheet(return value as name) ' -copy data(DataCols) from Sh to tempsheet ' -Sort data according to keys(keysCols) '- Error Handling: ' *if datacols is not array or contain only one element, then raise err ' *if keycols is not array or contains one element that is greater than count of datacols then raise err ' *if keysDigital is not array or ' keysDigital is not boolean array or ' keysDigital contain different count of elements of keysCols ' then rais err '============================================================== '************************************************************** Function SortSheet(Sh As String, DataCols As Variant, keysCols As Variant, keysDigital As Variant, MainCol As Integer, Optional StartRow As Integer) Dim Nsh As Worksheet Dim LastRow As Integer Dim i As Integer, j As Integer Dim Rng As String, aWb As String Dim SortKeyCol As Integer Const NEWSHEETNAME As String = "SortedSheet" Const ERRCODE As Integer = 11111 If StartRow = 0 Then StartRow = 1 LastRow = Sheets(Sh).Cells(Rows.Count, MainCol).End(xlUp).row If LastRow <= StartRow Then Exit Function 'if datacols is not array or contain only one element, then raise err If Not IsArray(DataCols) Then ERR.Raise ERRCODE If UBound(DataCols) - LBound(DataCols) = 1 Then ERR.Raise ERRCODE 'if keycols is not array or contains one element that is greater than count of datacols then raise err If Not IsArray(keysCols) Then ERR.Raise ERRCODE For i = LBound(keysCols) To UBound(keysCols) If keysCols(i) > UBound(DataCols) - LBound(DataCols) + 1 Then ERR.Raise ERRCODE Next i 'if keysDigital is not array or ' keysDigital is not boolean array or ' keysDigital contain different count of elements of keysCols 'then rais err If Not IsArray(keysDigital) Then ERR.Raise ERRCODE If Not (UBound(keysCols) - LBound(keysCols) = UBound(keysDigital) - LBound(keysDigital)) Then ERR.Raise ERRCODE For i = LBound(keysDigital) To UBound(keysDigital) If Not VarType(keysDigital(i)) = vbBoolean Then ERR.Raise ERRCODE Next i 'sort datacols QuickSort DataCols, LBound(DataCols), UBound(DataCols) 'copy data from sh aWb = ActiveSheet.Name Set Nsh = Sheets.Add Nsh.Name = NEWSHEETNAME For i = LBound(DataCols) To UBound(DataCols) Rng = Rng & ColLetter(DataCols(i)) & StartRow & ":" & ColLetter(DataCols(i)) & LastRow & "," Next i Rng = Left(Rng, Len(Rng) - 1) Sheets(Sh).Range(Rng).Copy Nsh.Activate Nsh.Paste 'merge keys into one column SortKeyCol = Columns.Count For i = 1 To LastRow - StartRow + 1 Nsh.Cells(i, SortKeyCol) = "" For j = LBound(keysCols) To UBound(keysCols) If CBool(keysDigital(j)) Then Nsh.Cells(i, SortKeyCol) = Nsh.Cells(i, SortKeyCol) & "_" & Format(Nsh.Cells(i, keysCols(j)), "00000.00") Else Nsh.Cells(i, SortKeyCol) = Nsh.Cells(i, SortKeyCol) & "_" & Nsh.Cells(i, keysCols(j)) End If Next j Next i 'sort Nsh.Cells.Sort key1:=Nsh.Columns(ColLetter(SortKeyCol) & ":" & ColLetter(SortKeyCol)), Order1:=xlAscending, _ Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Sheets(aWb).Activate SortSheet = NEWSHEETNAME End Function

例子

Private Sub Sample_SortSheet() Dim DataCols As Variant Dim keyCols As Variant Dim keyDigital As Variant DataCols = Array(33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46) keyCols = Array(1, 4, 5, 7, 14) keyDigital = Array(False, False, True, True, True) Call SortSheet("IOL", DataCols, keyCols, keyDigital, 41, 6) End Sub