VBA二维数组自定义排序
肝货，有味还用心。登高望远，海阔天空。
缘起
排序是Coder最常做的事情之一。对于Excel来说，常常是二维表的排序，今天我们权且当练练手，做一个冒泡排序。
- 时间复杂度:
- 平均情况：O(n^2)
- 最好情况: O (n)
- 最坏情况：O(n^2)
- 空间复杂度: O (1)
- 稳定性: 稳定
- 基本思想
- 重复的遍历待排序的数组，依次比较两个相邻的元素，若它们的顺序错误则调换位置，直至没有元素再需要交换为止。
- 具体步骤
- '比较两个相邻元素，如果前一个比后一个大，则交换这两个相邻元素
- '从头至尾对每一对相邻元素进行步骤1的操作，完成1次对整个待排序数字列表的遍历后，最大的元素就放在了该列表的最后一个位置上了
- '对除最后一个元素的所有元素重复上述步骤，这第二次遍历后第二大的元素就也放在了正确的位置（整个列表的倒数第二位置上）
- '不断重复上述步骤，每次遍历都会将一个元素放在正确的位置上，从而下次遍历的元素也会随之减少一个，直至没有任何一对数字需要比较
实现
类名：mySorts
'本类仅用于VBA，不可直接用于VB.net
'Base CodeFrom https://blog.csdn.net/m0_46067540/article/details/108941053
'原排序BubbleSort()原封未动
'该类用于二维数组的排序，包括
'直接赋予数组或直接赋予表格地址
'正序和逆序排列
'定义用于排序的列
'表头行（在数组内但不用于排序）
'改善部分：原排序修改为类,更方便使用
'2022/11/29
Option Explicit
Private myArray(), mySortArray()
Private myPositive As Boolean
Private myColumn As Long
Private myTitleRows As Integer
'----初始化----------------------------------------------------
Private Sub Class_Initialize()
myPositive = True
myColumn = 1
myTitleRows = 0
End Sub
'--------------------------------------------------------------
'----获取二维数组----------------------------------------------
Public Property Let Arr(ByVal Val)
If VBA.IsObject(Val) Then
myArray = Val.Value
myArray = Val
End If
End Property
Public Property Get Arr()
Arr = myArray
End Property
'--------------------------------------------------------------
'----设定Sort正反序--------------------------------------------
Public Property Let Positive(ByVal Val As Boolean)
myPositive = Val
End Property
Public Property Get Positive() As Boolean
Positive = myPositive
End Property
'--------------------------------------------------------------
'----设定排序列------------------------------------------------
Public Property Let Column(ByVal Val As Long)
myColumn = Val
End Property
Public Property Get Column() As Long
Column = myColumn
End Property
'--------------------------------------------------------------
'----设定标题行数----------------------------------------------
Public Property Let TitleRows(ByVal Val As Integer)
myTitleRows = Val
End Property
Public Property Get TitleRows() As Integer
TitleRows = myTitleRows
End Property
'--------------------------------------------------------------
'----一趟水的做法----------------------------------------------
Public Function SetAll(setArr, setPositive As Boolean, setColumn As Long, setTitleRows As Integer)
If VBA.IsObject(setArr) Then
myArray = setArr.Value
myArray = setArr
End If
myPositive = setPositive
myColumn = setColumn
myTitleRows = setTitleRows
Call DoSort
SetAll = mySortArray
End Function
'--------------------------------------------------------------
'----分步的做法------------------------------------------------
Public Property Get SortArray()
DoSort
SortArray = mySortArray
End Property
'--------------------------------------------------------------
'----核心排序--------------------------------------------------------------------------------------
Private Sub DoSort()
mySortArray = myArray
mySortArray = BubbleSort(mySortArray, myPositive, myColumn, myTitleRows)
End Sub
Private Function BubbleSort(ByRef SnArray(), Sort As Boolean, Column As Long, Title As Integer) '冒泡排序
'Sort 为升降序标记
'Column为需排序列
'Title为标题行数（不参与排序的行数）
Dim IOuter As Long, IInner As Long, ILbound As Long, IUbound As Long
Dim IsSort As Boolean
Dim Count As Integer, Temp As Integer, SORTED As Integer
Dim Lastindex As Double, TLbound As Double, TUbound As Double
Dim Itemp
ReDim Itemp(1, LBound(SnArray, 2) To UBound(SnArray, 2))
Lastindex = 0
TLbound = LBound(SnArray, 2)
TUbound = UBound(SnArray, 2)
ILbound = LBound(SnArray) + Title
IUbound = UBound(SnArray)
SORTED = IUbound - IOuter - 1
Select Case Sort
Case 0 '参数为0时升序
For IOuter = ILbound To IUbound - 1
IsSort = True
For IInner = ILbound To SORTED 'iubound - iouter - 1
If SnArray(IInner, Column) > SnArray(IInner + 1, Column) Then
For Temp = TLbound To TUbound '数组整行数据交换
Itemp(1, Temp) = SnArray(IInner, Temp)
SnArray(IInner, Temp) = SnArray(IInner + 1, Temp)
SnArray(IInner + 1, Temp) = Itemp(1, Temp)
Next Temp
IsSort = False '标记是否有排序动作
Count = Count + 1 '记录排序次数，可删除
Lastindex = IInner '记录最后排序位置
End If
Next IInner
If IsSort = True Then Exit For '如果没有排序动作则为全部排序完成，跳出循环，排序结束
SORTED = Lastindex '接下来的循环只到最后排序位置
Next IOuter
Case 1 '参数为1时降序
For IOuter = ILbound To IUbound - 1
IsSort = True
For IInner = ILbound To SORTED 'iubound - iouter - 1
If SnArray(IInner, Column) < SnArray(IInner + 1, Column) Then
For Temp = TLbound To TUbound '数组整行数据交换
Itemp(1, Temp) = SnArray(IInner, Temp)
SnArray(IInner, Temp) = SnArray(IInner + 1, Temp)
SnArray(IInner + 1, Temp) = Itemp(1, Temp)
Next Temp
IsSort = False '标记是否有排序动作
Count = Count + 1 '记录排序次数，可删除
Lastindex = IInner '记录最后排序位置
End If
Next IInner
If IsSort = True Then Exit For '如果没有排序动作则为全部排序完成，跳出循环，排序结束
SORTED = Lastindex '接下来的循环只到最后排序位置
Next IOuter
Case Else
End Select
'Sheets(1).Range("I1") = Count
BubbleSort = SnArray
End Function
'--------------------------------------------------------------------------------------------------调用
新建模块测试类的结果。如有Bug则有必要调整输入内容的格式，比如某些长纯数字字符串代表的编码。
'本类仅用于VBA，不可直接用于VB.net
Private Sub SortsTest()
'锁定表，具体SthName请自行指定
Dim SthName As String
SthName = "指定的表名"
'锁定单元格，具体Range地址请自行指定
Dim GetAddress As String, PutAddress As String
GetAddress = "F13:K24"
PutAddress = "M13:R24"
'With方式
With New mySorts
Sheets(SthName).Range(PutAddress) = .SetAll(Sheets(SthName).Range(GetAddress), 1, 2, 0)
End With
'定义类方式
Dim NewSort As New mySorts
'极简方式
Sheets(SthName).Range(PutAddress) = NewSort.SetAll(Sheets(SthName).Range(GetAddress), 1, 2, 0)
'分步方式
'以下两种定义方式结果一致
NewSort.Arr = Sheets(SthName).Range(GetAddress).value
NewSort.Arr = Sheets(SthName).Range(GetAddress)