我使用宏按一列中的数据对表格进行排序：
ActiveWorkbook.Worksheets("sheet").Sort.SortFields.Add Key:=Range(sortRange), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
有没有办法让这段代码按以下顺序排序：首先是 0-9，然后是 A-Z，然后是特殊字符（至少有 • 和 +，我希望在排序顺序中排在最后）？
【问题讨论】：
标签： excel vba sorting columnsorting
好的，这听起来很有趣，所以我尝试了 Vityata 的方法，在另一个工作表中使用不同的列表。
Sub crazySort()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastRow As Long
Dim yourcolumnindex, letters, numbers, others As Long
Dim i As Long
Set ws = Worksheets("sheet")
'This is the sheet for our temp lists, rename accordingly
Set ws2 = Worksheets("tempsheet")
columnsCount = x
i = 1
letters = 1
others = 1
numbers = 1
With ws
For j = 1 to columnsCount
'loop through all the cells in your column
'change yourcolumnindex accordingly
Do While .Cells(i, j) <> ""
'check for the ASCII-code of the first character in every list
Select Case Asc(Left(.Cells(i, j), 1))
Case 65 To 90, 97 To 122
'if it's a letter, put it in column 1
ws2.Cells(letters, 1) = .Cells(i, j)
letters = letters + 1
Case 48 To 57
'if it's a cipher, put it in column 2
ws2.Cells(numbers, 2) = .Cells(i, j)
numbers = numbers + 1
Case Else
'is it something else, put it in column 3
ws2.Cells(others, 3) = .Cells(i, j)
others = others + 1
End Select
i = i + 1
Loop
Next
End With
End Sub
这部分只包含拆分列表，但从这里开始只是排序和复制/粘贴。
玩得开心。
【讨论】：
columnsCount = x 更改为最后一列的索引即可。如果您的第一列不是A，则相应地更改j=1。请记住，这会将源表的 all 列的值放在 tempsheet 的三列中。
@Tom，谢谢你提到我 :) 实际上，我正在考虑类似这样的事情：
Public Sub SortMe(rng_selection As Range)
Dim rng_cell As Range
Dim lst_numbers As New Collection
Dim lst_letters As New Collection
Dim lst_others As New Collection
Dim rng_new As Range
For Each rng_cell In rng_selection
Select Case Asc(Left(rng_cell, 1))
Case 65 To 90, 97 To 122
lst_letters.Add rng_cell.Text
Case 48 To 58
lst_numbers.Add rng_cell.Text
Case Else
lst_others.Add rng_cell.Text
End Select
Next rng_cell
Call SortCollection(lst_numbers)
Call SortCollection(lst_letters)
Call SortCollection(lst_others)
For Each rng_cell In rng_selection
If lst_numbers.Count Then
rng_cell = lst_numbers.Item(1)
lst_numbers.Remove (1)
ElseIf lst_letters.Count Then
rng_cell = lst_letters.Item(1)
lst_letters.Remove (1)
ElseIf lst_others.Count Then
rng_cell = lst_others(1)
lst_others.Remove (1)
End If
Next rng_cell
Set rng_new = rng_selection.Offset(0, 1)
End Sub
Sub SortCollection(ByRef oCollection As Collection, Optional bSortAscending As Boolean = True)
'taken from http://visualbasic.happycodings.com/applications-vba/code27.html
Dim lSort1 As Long, lSort2 As Long
Dim vTempItem1 As Variant, vTempItem2 As Variant, bSwap As Boolean
On Error GoTo ErrFailed
For lSort1 = 1 To oCollection.Count - 1
For lSort2 = lSort1 + 1 To oCollection.Count
If bSortAscending Then
If oCollection(lSort1) > oCollection(lSort2) Then
bSwap = True
Else
bSwap = False
End If
Else
If oCollection(lSort1) < oCollection(lSort2) Then
bSwap = True
Else
bSwap = False
End If
End If
If bSwap Then
'Store the items
If VarType(oCollection(lSort1)) = vbObject Then
Set vTempItem1 = oCollection(lSort1)
Else
vTempItem1 = oCollection(lSort1)
End If
If VarType(oCollection(lSort2)) = vbObject Then
Set vTempItem2 = oCollection(lSort2)
Else
vTempItem2 = oCollection(lSort2)
End If
'Swap the items over
oCollection.Add vTempItem1, , lSort2
oCollection.Add vTempItem2, , lSort1
'Delete the original items
oCollection.Remove lSort1 + 1
oCollection.Remove lSort2 + 1
End If
Next
Next
Exit Sub
ErrFailed:
Debug.Print "Error with CollectionSort: " & Err.Description
CollectionSort = Err.Number
On Error GoTo 0
End Sub
只是看起来很大，排序子很大，但是我复制并粘贴了它。它对我有用。如果要调用它，请在即时窗口中写入call SortMe(selection)，并且不要忘记选择范围。 :) 祝你有个愉快的夜晚 :D
【讨论】：