1，一维数组冒泡排序函数
Function bubble_sort(ByVal arr, Optional mode$ = "+")
'函数定义bubble_sort(数组，排序模式)对一维数组数据进行排序，返回一个有序一维数组
'2种排序模式，"+"即升序、"-"即降序
Dim i&, j&, sorted As Boolean, temp, last_index&, sort_border&
sort_border = UBound(arr) - 1 '排序边界，之后为有序，减少循环
If mode = "+" Then
For i = LBound(arr) To UBound(arr)
sorted = True '初始为有序，避免中途有序后的无效循环
For j = LBound(arr) To sort_border
If arr(j) > arr(j + 1) Then '交换数据
temp = arr(j): arr(j) = arr(j + 1): arr(j + 1) = temp
sorted = False: last_index = j '最后排序的序号
End If
Next
sort_border = last_index ': Debug.Print "sort_border", sort_border
If sorted Then Exit For '如果为有序，则退出循环
Next
ElseIf mode = "-" Then
For i = LBound(arr) To UBound(arr)
sorted = True
For j = LBound(arr) To sort_border
If arr(j) < arr(j + 1) Then
temp = arr(j): arr(j) = arr(j + 1): arr(j + 1) = temp
sorted = False: last_index = j
End If
Next
sort_border = last_index ': Debug.Print "sort_border", sort_border
If sorted Then Exit For
Next
End If
bubble_sort = arr
End Function
2，二维数组冒泡排序函数
单列排序版
注意：仅适用对二维数组的单列值进行排序，且在数字文字混合且数字位数不同的情况下，排序错误（不推荐使用）
Function bubble_sort_arr(ByVal arr, col&, Optional mode$ = "+")
'函数定义bubble_sort_arr(数组，排序列，排序模式)对二维数组数据的指定列进行排序，返回一个有序二维数组
'2种排序模式，"+"即升序、"-"即降序
Dim i&, j&, t&, sorted As Boolean, temp, last_index&, sort_border&
sort_border = UBound(arr) - 1 '排序边界，之后为有序，减少循环
If mode = "+" Then
For i = LBound(arr) To UBound(arr)
sorted = True '初始为有序，避免中途有序后的无效循环
For j = LBound(arr) To sort_border
If arr(j, col) > arr(j + 1, col) Then
For t = LBound(arr, 2) To UBound(arr, 2) '交换数据，数组整行
temp = arr(j, t): arr(j, t) = arr(j + 1, t): arr(j + 1, t) = temp
Next
sorted = False: last_index = j '最后排序的序号
End If
Next
sort_border = last_index ': Debug.Print "sort_border", sort_border
If sorted Then Exit For '如果为有序，则退出循环
Next
ElseIf mode = "-" Then
For i = LBound(arr) To UBound(arr)
sorted = True
For j = LBound(arr) To sort_border
If arr(j, col) < arr(j + 1, col) Then
For t = LBound(arr, 2) To UBound(arr, 2)
temp = arr(j, t): arr(j, t) = arr(j + 1, t): arr(j + 1, t) = temp
Next
sorted = False: last_index = j
End If
Next
sort_border = last_index ': Debug.Print "sort_border", sort_border
If sorted Then Exit For
Next
End If
bubble_sort_arr = arr
End Function
举例
《excel吧提问-按数字大小排序》，由于数据不规范、数字序号的位数不同，因此需要先对数据进行分割，然后调用函数排序
考虑到实际应用中可能存在不同年度，因此先对“执”字之前的内容排序，再分别对“执”字之前同样内容的“执”字之后的内容排序
Sub 排序测试()
tm = Now()
Dim arr, temp, brr, crr, result, i, j, k, first, last, write_col, write_row
'------参数填写
write_col = "e" '写入区域，列名，附加在列尾
Cells(1, write_col).Value = "标题"
arr = [b2:b19].Value
ReDim Preserve arr(1 To UBound(arr), 1 To 3)
For i = 1 To UBound(arr)
temp = Split(arr(i, 1), "执")
arr(i, 2) = temp(0): arr(i, 3) = Val(temp(1)) 'val()提取文字前的数字
Next
brr = bubble_sort_arr(arr, 2, "+") '对"执"之前的内容排序
first = 1
For j = 1 To UBound(brr) - 1
If brr(j, 2) <> brr(j + 1, 2) Then '对"执"之前的内容相等的排序
last = j
ReDim crr(1 To last - first + 1, 1 To 2)
For k = first To last '数组截取
crr(k - first + 1, 1) = brr(k, 1): crr(k - first + 1, 2) = brr(k, 3)
Next
result = bubble_sort_arr(crr, 2, "+")
write_row = Cells(1, write_col).CurrentRegion.Rows.count + 1
Cells(write_row, write_col).Resize(UBound(result), 1) = result '仅返回排序后的内容
ElseIf j = UBound(brr) - 1 Then '最后一组数据，无论单行多行
last = UBound(brr)
ReDim crr(1 To last - first + 1, 1 To 2)
For k = first To last '数组截取
crr(k - first + 1, 1) = brr(k, 1): crr(k - first + 1, 2) = brr(k, 3)
Next
result = bubble_sort_arr(crr, 2, "+")
write_row = Cells(1, write_col).CurrentRegion.Rows.count + 1
Cells(write_row, write_col).Resize(UBound(result), 1) = result '仅返回排序后的内容
Exit For '结束循环
End If
first = last + 1 '重置开始行
Next
Debug.Print ("排序完成，累计用时" & Format(Now() - tm, "hh:mm:ss")) '耗时
End Sub
返回结果
多列排序版
多列排序：对需要排序的多列依次排序，除第1列外后面需要排序的列，需要在前一列值相同的情况下进行排序
2.1，字符串拼接法
代码思路：对需要排序的n列的值提取出来，每行拼接为1个字符串，并标记所属行号，组成多行2列数组，再对拼接字符串进行排序，最后将原始数组按排序后的行号顺序写入新数组输出
和单列排序版一样，在数字文字混合且数字位数不同的情况下，排序错误
Function bubble_sort2d(ByVal arr, ByVal key_col, Optional mode$ = "+")
'函数定义bubble_sort2d(数组，列号数组，排序模式)对二维数组数据的指定列号数组进行排序，返回一个有序二维数组
'2种排序模式，"+"即升序、"-"即降序；字符串拼接法；返回数组从1开始计数
Dim i&, j&, m&, n&, r&, t&, sorted As Boolean, temp, last_index&, sort_border&, delimiter$, s$
If LBound(arr) = 0 Or LBound(arr, 2) = 0 Then '转为从1开始计数
arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
End If
m = UBound(arr): n = UBound(arr, 2): sort_border = m - 1: delimiter = Chr(28) '分隔符
ReDim result(1 To m, 1 To n): ReDim brr(1 To m, 1 To 2) '结果、临时数组
For i = 1 To m 'key_col列号数组对应值进行拼接、行号写入brr
s = ""
For Each c In key_col
s = s & delimiter & arr(i, c)
Next
brr(i, 1) = Mid(s, 2): brr(i, 2) = i
Next
For i = 1 To m '对brr排序，升序
sorted = True '初始为有序，避免中途有序后的无效循环
For j = 1 To sort_border
If brr(j, 1) > brr(j + 1, 1) Then
For t = 1 To 2 '交换数据，数组整行
temp = brr(j, t): brr(j, t) = brr(j + 1, t): brr(j + 1, t) = temp
Next
sorted = False: last_index = j '最后排序的序号
End If
Next
sort_border = last_index
If sorted Then Exit For '如果为有序，则退出循环
Next
If mode = "+" Then '写入结果数组
For i = 1 To m
r = brr(i, 2) '对应brr排序行号
For j = 1 To n
result(i, j) = arr(r, j)
Next
Next
ElseIf mode = "-" Then
For i = 1 To m
r = brr(m + 1 - i, 2)
For j = 1 To n
result(i, j) = arr(r, j)
Next
Next
End If
bubble_sort2d = result
End Function
2.2，逐步字符串拼接法，数组版
代码思路：与2.1大体一样，对需要排序的n列的值提取出来、加上一列对应所属行号，组成多行n+1列数组brr，依次对数组1-n列进行排序，且如果当前排序列之前有多列（2列以上）以排序的值，则将值拼接为字符串，写入当前排序列的前一列，最后将原始数组按排序后的行号顺序写入新数组输出
与2.1不同，需要排序列中包含纯数字列，且数字位数不同的，最终排序结果正确（推荐使用）
Function bubble_sort2d_v1(ByVal arr, ByVal key_col, Optional mode$ = "+")
'函数定义bubble_sort2d_v1(数组，列号数组，排序模式)对二维数组数据的指定列号数组进行排序，返回一个有序二维数组
'2种排序模式，"+"即升序、"-"即降序；数组字符串拼接法；返回数组从1开始计数
Dim i&, j&, m&, n&, r&, t&, sorted As Boolean, temp, last_index&, sort_border&, delimiter$
If LBound(arr) = 0 Or LBound(arr, 2) = 0 Then '转为从1开始计数
arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
End If
m = UBound(arr): n = UBound(arr, 2): sort_border = m - 1: delimiter = Chr(28) '分隔符
k = UBound(key_col) - LBound(key_col) + 1
ReDim result(1 To m, 1 To n): ReDim brr(1 To m, 1 To k + 1) '结果、临时数组
For i = 1 To m 'key_col列号数组对应值、行号写入brr
For Each c In key_col
j = j + 1: brr(i, j) = arr(i, c)
Next
j = 0: brr(i, k + 1) = i
Next
For i = 1 To m '对brr第1列排序，升序
sorted = True '初始为有序，避免中途有序后的无效循环
For j = 1 To sort_border
If brr(j, 1) > brr(j + 1, 1) Then
For t = 1 To UBound(brr, 2) '交换数据，数组整行
temp = brr(j, t): brr(j, t) = brr(j + 1, t): brr(j + 1, t) = temp
Next
sorted = False: last_index = j '最后排序的序号
End If
Next
sort_border = last_index
If sorted Then Exit For '如果为有序，则退出循环
Next
Dim kk&, r_s&, r_e&, s$
kk = 2: r_s = 1: r_e = 1: s = brr(1, 1) '当前排序列号；开始、结束行号；开始值
Do While k > 1 And kk <= k 'key_col有多个值，则依次按列排序，字符串拼接法
For i = r_s + 1 To m
If brr(i, kk - 1) = s Then r_e = i Else Exit For '更新结束行号
Next
If r_s <> r_e Then '需要排序的部分
sort_border = r_e - 1
For i = r_s To r_e
sorted = True
For j = r_s To sort_border
If brr(j, kk) > brr(j + 1, kk) Then
For t = 1 To UBound(brr, 2)
temp = brr(j, t): brr(j, t) = brr(j + 1, t): brr(j + 1, t) = temp
Next
sorted = False: last_index = j
End If
Next
sort_border = last_index
If sorted Then Exit For
Next
End If
r_s = r_e + 1: r_e = r_e + 1 '更新值：开始、结束行号，开始值
If r_s >= m Then
kk = kk + 1: r_s = 1: r_e = 1
If kk > 2 And kk <= k Then '当前排序列号 >2 时，前2列字符串合并至kk-1列（即kk-2和kk-1合并）
For i = 1 To m
brr(i, kk - 1) = brr(i, kk - 2) & delimiter & brr(i, kk - 1)
Next
End If
End If
s = brr(r_s, kk - 1)
Loop
If mode = "+" Then '写入结果数组
For i = 1 To m
r = brr(i, k + 1) '对应brr排序行号
For j = 1 To n
result(i, j) = arr(r, j)
Next
Next
ElseIf mode = "-" Then
For i = 1 To m
r = brr(m + 1 - i, k + 1)
For j = 1 To n
result(i, j) = arr(r, j)
Next
Next
End If
bubble_sort2d_v1 = result
End Function
2.3，逐步字符串拼接法，字典版
代码思路：与2.2大体一样，对当前排序列前一列的值不使用循环判断相等，而是写入字典，字典键为前一列的值，字典值为数组（计数、开始行号、结束行号）。再遍历字典，对计数 >2 的数组 开始行号-结束行号 进行排序，最后将原始数组按排序后的行号顺序写入新数组输出
与2.2一样，需要排序列中包含纯数字列，且数字位数不同的，最终排序结果正确
Function bubble_sort2d_v2(ByVal arr, ByVal key_col, Optional mode$ = "+")
'函数定义bubble_sort2d_v2(数组，列号数组，排序模式)对二维数组数据的指定列号数组进行排序，返回一个有序二维数组
'2种排序模式，"+"即升序、"-"即降序；字典字符串拼接法；返回数组从1开始计数
Dim i&, j&, m&, n&, r&, t&, sorted As Boolean, temp, last_index&, sort_border&, delimiter$
If LBound(arr) = 0 Or LBound(arr, 2) = 0 Then '转为从1开始计数
arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
End If
m = UBound(arr): n = UBound(arr, 2): sort_border = m - 1: delimiter = Chr(28) '分隔符
k = UBound(key_col) - LBound(key_col) + 1
ReDim result(1 To m, 1 To n): ReDim brr(1 To m, 1 To k + 1) '结果、临时数组
For i = 1 To m 'key_col列号数组对应值、行号写入brr
For Each c In key_col
j = j + 1: brr(i, j) = arr(i, c)
Next
j = 0: brr(i, k + 1) = i
Next
For i = 1 To m '对brr第1列排序，升序
sorted = True '初始为有序，避免中途有序后的无效循环
For j = 1 To sort_border
If brr(j, 1) > brr(j + 1, 1) Then
For t = 1 To UBound(brr, 2) '交换数据，数组整行
temp = brr(j, t): brr(j, t) = brr(j + 1, t): brr(j + 1, t) = temp
Next
sorted = False: last_index = j '最后排序的序号
End If
Next
sort_border = last_index
If sorted Then Exit For '如果为有序，则退出循环
Next
Dim kk&, dict As Object, r_s&, r_e&
kk = 2: Set dict = CreateObject("scripting.dictionary") '当前排序列号，字典
Do While k > 1 And kk <= k 'key_col有多个值，则依次按列排序，字典字符串拼接法
If kk > 2 Then '当前排序列号 >2 时，前2列字符串合并至kk-1列（即kk-2和kk-1合并）
For i = 1 To m
brr(i, kk - 1) = brr(i, kk - 2) & delimiter & brr(i, kk - 1)
Next
End If
For i = 1 To m 'kk-1列值写入字典
temp = brr(i, kk - 1)
If Not dict.Exists(temp) Then
dict(temp) = Array(1, i, i) '计数、开始行号、结束行号
Else
c = dict(temp)(0) + 1: dict(temp) = Array(c, dict(temp)(1), i)
End If
Next
For Each ks In dict.keys
If dict(ks)(0) > 1 Then '有重复值，则需排序
r_s = dict(ks)(1): r_e = dict(ks)(2): sort_border = r_e - 1 '开始行号、结束行号
For i = r_s To r_e
sorted = True
For j = r_s To sort_border
If brr(j, kk) > brr(j + 1, kk) Then
For t = 1 To UBound(brr, 2)
temp = brr(j, t): brr(j, t) = brr(j + 1, t): brr(j + 1, t) = temp
Next
sorted = False: last_index = j
End If
Next
sort_border = last_index
If sorted Then Exit For
Next
End If
Next
kk = kk + 1: dict.RemoveAll
Loop
If mode = "+" Then '写入结果数组
For i = 1 To m
r = brr(i, k + 1) '对应brr排序行号
For j = 1 To n
result(i, j) = arr(r, j)
Next
Next
ElseIf mode = "-" Then
For i = 1 To m
r = brr(m + 1 - i, k + 1)
For j = 1 To n
result(i, j) = arr(r, j)
Next
Next
End If
bubble_sort2d_v2 = result
End Function
3种代码对比
以单列排序版举例为例
Sub bubble_sort2d测试()
Dim arr, brr
arr = [a2:b19]
brr = bubble_sort2d(arr, Array(1, 2))
[d2].Resize(UBound(brr), UBound(brr, 2)) = brr
brr = bubble_sort2d_v1(arr, Array(1, 2))
[g2].Resize(UBound(brr), UBound(brr, 2)) = brr
brr = bubble_sort2d_v2(arr, Array(1, 2))
[j2].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub
2列都是数字文字混合的数据，3种代码排序结果相同
第2列为纯数字，2.1排序错误，其他2种排序正确
第2列统一数字位数，3种代码排序结果相同
3种代码运行速度，随机数排序耗时秒数，速度都挺快的
参考资料：《冒泡排序》
扫一扫
2979
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
