二维（以下）数组排序的自定义函数

microyip

今天早上因需要，把自用的二维（以下）数组排序的自定义函数进行调整修改，并加以注释供有需要的人参考使用。如有进一步优化的可能，望高手不吝赐教，亦望使用者指正有误之处。

1. Function VariantSort(ByVal vData As Variant, Optional ByVal nSortCol As Variant, Optional ByVal bValIsStr As Boolean = False, Optional sReplaceToVal As String, Optional ByVal bDownSort As Boolean = False) As Variant   '数组排序
   
2. '对二维以下数组排序，nSortCol需要排序的列数，bValIsStr是否按字符串形式比较，sReplaceToVal是替换为空再比较数值的字符串，bDownSort是否降序排序
   
3. '返回值说明：
   
4. '      Empty：设定排序列数大于数组列数
   
5. '      错误信息：数组维数大于2
   
6. '      原vData值：非数组
   
7. '      数组：已经按要求排序的数组
   
8.     Dim nDimension As Integer '维度
   
9.     Dim nRow As Double, nCol As Double, vTmp As Variant, nJ As Double, vVal As Variant
   
10.    
    
11.     On Error Resume Next
    
12.     If IsArray(vData) Then
    
13.         For nDimension = 0 To 3
    
14.             nRow = UBound(vData, nDimension + 1)
    
15.             If Err.Number <> 0 Then Exit For
    
16.         Next
    
17.     Else
    
18.         nDimension = -1 '表示非数组
    
19.     End If
    
20.    
    
21.     If IsArray(vData) Then '判断是否数组
    
22.         On Error Resume Next '考虑需要确定数组维数，使用遇错方式来处理。遇错继续执行下一句
    
23.         For nDimension = 0 To 3
    
24.             nRow = UBound(vData, nDimension + 1) '获取对应维度数组的最大行数
    
25.             If Err.Number <> 0 Then Exit For '遇出错时，表示数组没有nDimension + 1维度
    
26.         Next
    
27.         On Error GoTo 0 '恢复遇错时进入调试模式
    
28.    
    
29.         If nDimension > 2 Then
    
30.             vData = "数组维数大于2“"
    
31.         ElseIf IsMissing(nSortCol) Then '参数被忽略输入时
    
32.             If nDimension = 2 Then nSortCol = LBound(vData, 2) '当维度为2时，默认以第一列为排序对象
    
33.         ElseIf nDimension = 2 And nSortCol > UBound(vData, 2) Then '当需要排序的维度大于实际数组维度时
    
34.             vData = Empty
    
35.         End If
    
36.     End If
    
37.     If IsArray(vData) Then
    
38.         ReDim vVal(1 To 2) '定义数组用于记录需要比较的两个数
    
39.         nJ = LBound(vData) '记录起始的行数
    
40.         For nRow = LBound(vData) To UBound(vData) - 1 '因需比较当前与下一行数值，所以最大行数只能到UBound(vData) - 1
    
41.             If nDimension = 1 Then '维度为1时
    
42.                 If bValIsStr Then '比较对象是字符串形式比较时
    
43.                     If sReplaceToVal = "" Then
    
44.                         vVal(1) = CStr(vData(nRow)) '当前行的字符串，强制转换为字符串形式
    
45.                         vVal(2) = CStr(vData(nRow + 1)) '下一行的字符串，强制转换为字符串形式
    
46.                     Else '需替换指定字符串再进行数值上的比较
    
47.                         vVal(1) = Val(Replace(CStr(vData(nRow)), sReplaceToVal, "")) '当前行的字符串替换指定字符串为空后的数值，强制转换为数字形式
    
48.                         vVal(2) = Val(Replace(CStr(vData(nRow + 1)), sReplaceToVal, "")) '下一行的字符串替换指定字符串为空后的数值，强制转换为数字形式
    
49.                     End If
    
50.                 Else
    
51.                     vVal(1) = vData(nRow)
    
52.                     vVal(2) = vData(nRow + 1)
    
53.                 End If
    
54.             Else '维度为2时
    
55.                 If bValIsStr Then
    
56.                     If sReplaceToVal = "" Then
    
57.                         vVal(1) = CStr(vData(nRow, nSortCol))
    
58.                         vVal(2) = CStr(vData(nRow + 1, nSortCol))
    
59.                     Else
    
60.                         vVal(1) = Val(Replace(CStr(vData(nRow, nSortCol)), sReplaceToVal, ""))
    
61.                         vVal(2) = Val(Replace(CStr(vData(nRow + 1, nSortCol)), sReplaceToVal, ""))
    
62.                     End If
    
63.                 Else
    
64.                     vVal(1) = vData(nRow, nSortCol)
    
65.                     vVal(2) = vData(nRow + 1, nSortCol)
    
66.                 End If
    
67.             End If
    
68.             If (bDownSort And vVal(1) >= vVal(2)) Or (Not bDownSort And vVal(1) <= vVal(2)) Then '符合指定排序时，交换记录已经比较到哪行
    
69.                 If nRow > nJ Then
    
70.                     nJ = nRow
    
71.                 Else
    
72.                     nRow = nJ
    
73.                 End If
    
74.             Else '不符合指定排序时，交换当前行与下一行数值
    
75.                 If nDimension = 1 Then
    
76.                     vTmp = vData(nRow)
    
77.                     vData(nRow) = vData(nRow + 1)
    
78.                     vData(nRow + 1) = vTmp
    
79.                 Else
    
80.                     vTmp = vData(nRow, nSortCol)
    
81.                     vData(nRow, nSortCol) = vData(nRow + 1, nSortCol)
    
82.                     vData(nRow + 1, nSortCol) = vTmp
    
83.                 End If
    
84.                 If nRow <> LBound(vData) Then nRow = nRow - 2
    
85.             End If
    
86.         Next nRow
    
87.     End If
    
88.     VariantSort = vData '返回结果
    
89. End Function

复制代码

调用方式

1. Sub SortVal(ByVal nType As Integer)
   
2.     Dim vData As Variant
   
3.    
   
4.     With Sheet1
   
5.         With .[A1].CurrentRegion '对与A1连续的单元格进行处理
   
6.             vData = .Offset(1).Resize(.Rows.Count - 1).Value '获取数值
   
7.         End With
   
8.         If nType = 1 Then '对第二列数字进行降序排序
   
9.             vData = VariantSort(vData, 2, , , True)
   
10.         ElseIf nType = 2 Then '对第三列文字进行排序
    
11.             vData = VariantSort(vData, 3, True)
    
12.         ElseIf nType = 3 Then '对第三列去除指定文字后转为数字进行排序
    
13.             vData = VariantSort(vData, 3, True, "Lang_Module")
    
14.         ElseIf nType = 4 Then '默认对第一列文字进行排序
    
15.             vData = VariantSort(vData)
    
16.         End If
    
17.         With .[G2]
    
18.             .CurrentRegion.Offset(1).ClearContents '清除已有结果
    
19.             .Resize(UBound(vData), 3) = vData '写入排序结果
    
20.         End With
    
21.     End With
    
22. End Sub

复制代码

microyip

鄂龙蒙 发表于 2019-6-14 10:53
附件不知为什么上传不了。

多谢你的指正，现在修复Bug重新发代码

1. Sub SortVal(ByVal nType As Integer)
   
2.     Dim vData As Variant
   
3.    
   
4.     With Sheet1
   
5.         With .[A1].CurrentRegion '对与A1连续的单元格进行处理
   
6.             vData = .Offset(1).Resize(.Rows.Count - 1).Value '获取数值
   
7.         End With
   
8.         If nType = 1 Then '对第二列数字进行降序排序
   
9.             vData = VariantSort(vData, 2, , , True)
   
10.         ElseIf nType = 2 Then '对第三列文字进行排序
    
11.             vData = VariantSort(vData, 3, True)
    
12.         ElseIf nType = 3 Then '对第三列去除指定文字后转为数字进行排序
    
13.             vData = VariantSort(vData, 3, True, "Lang_Module")
    
14.         ElseIf nType = 4 Then '默认对第一列文字进行排序
    
15.             vData = VariantSort(vData)
    
16.         End If
    
17.         With .[G2]
    
18.             .CurrentRegion.Offset(1).ClearContents '清除已有结果
    
19.             .Resize(UBound(vData), 3) = vData '写入排序结果
    
20.         End With
    
21.     End With
    
22. End Sub
    
23. 
    
24. Function VariantSort(ByVal vData As Variant, Optional ByVal nSortCol As Variant, Optional ByVal bValIsStr As Boolean = False, Optional sReplaceToVal As String, Optional ByVal bDownSort As Boolean = False) As Variant   '数组排序
    
25. '对二维以下数组排序，nSortCol需要排序的列数，bValIsStr是否按字符串形式比较，sReplaceToVal是替换为空再比较数值的字符串，bDownSort是否降序排序
    
26. '返回值说明：
    
27. '      Empty：设定排序列数大于数组列数
    
28. '      错误信息：数组维数大于2
    
29. '      原vData值：非数组
    
30. '      数组：已经按要求排序的数组
    
31.     Dim nDimension As Integer '维度
    
32.     Dim nRow As Double, nCol As Double, vTmp As Variant, nJ As Double, vVal As Variant
    
33.    
    
34.     On Error Resume Next
    
35.     If IsArray(vData) Then
    
36.         For nDimension = 0 To 3
    
37.             nRow = UBound(vData, nDimension + 1)
    
38.             If Err.Number <> 0 Then Exit For
    
39.         Next
    
40.     Else
    
41.         nDimension = -1 '表示非数组
    
42.     End If
    
43.    
    
44.     If IsArray(vData) Then '判断是否数组
    
45.         On Error Resume Next '考虑需要确定数组维数，使用遇错方式来处理。遇错继续执行下一句
    
46.         For nDimension = 0 To 3
    
47.             nRow = UBound(vData, nDimension + 1) '获取对应维度数组的最大行数
    
48.             If Err.Number <> 0 Then Exit For '遇出错时，表示数组没有nDimension + 1维度
    
49.         Next
    
50.         On Error GoTo 0 '恢复遇错时进入调试模式
    
51.    
    
52.         If nDimension > 2 Then
    
53.             vData = "数组维数大于2“"
    
54.         ElseIf IsMissing(nSortCol) Then '参数被忽略输入时
    
55.             If nDimension = 2 Then nSortCol = LBound(vData, 2) '当维度为2时，默认以第一列为排序对象
    
56.         ElseIf nDimension = 2 And nSortCol > UBound(vData, 2) Then '当需要排序的维度大于实际数组维度时
    
57.             vData = Empty
    
58.         End If
    
59.     End If
    
60.     If IsArray(vData) Then
    
61.         ReDim vVal(1 To 2) '定义数组用于记录需要比较的两个数
    
62.         nJ = LBound(vData) '记录起始的行数
    
63.         For nRow = LBound(vData) To UBound(vData) - 1 '因需比较当前与下一行数值，所以最大行数只能到UBound(vData) - 1
    
64.             If nDimension = 1 Then '维度为1时
    
65.                 If bValIsStr Then '比较对象是字符串形式比较时
    
66.                     If sReplaceToVal = "" Then
    
67.                         vVal(1) = CStr(vData(nRow)) '当前行的字符串，强制转换为字符串形式
    
68.                         vVal(2) = CStr(vData(nRow + 1)) '下一行的字符串，强制转换为字符串形式
    
69.                     Else '需替换指定字符串再进行数值上的比较
    
70.                         vVal(1) = Val(Replace(CStr(vData(nRow)), sReplaceToVal, "")) '当前行的字符串替换指定字符串为空后的数值，强制转换为数字形式
    
71.                         vVal(2) = Val(Replace(CStr(vData(nRow + 1)), sReplaceToVal, "")) '下一行的字符串替换指定字符串为空后的数值，强制转换为数字形式
    
72.                     End If
    
73.                 Else
    
74.                     vVal(1) = vData(nRow)
    
75.                     vVal(2) = vData(nRow + 1)
    
76.                 End If
    
77.             Else '维度为2时
    
78.                 If bValIsStr Then
    
79.                     If sReplaceToVal = "" Then
    
80.                         vVal(1) = CStr(vData(nRow, nSortCol))
    
81.                         vVal(2) = CStr(vData(nRow + 1, nSortCol))
    
82.                     Else
    
83.                         vVal(1) = Val(Replace(CStr(vData(nRow, nSortCol)), sReplaceToVal, ""))
    
84.                         vVal(2) = Val(Replace(CStr(vData(nRow + 1, nSortCol)), sReplaceToVal, ""))
    
85.                     End If
    
86.                 Else
    
87.                     vVal(1) = vData(nRow, nSortCol)
    
88.                     vVal(2) = vData(nRow + 1, nSortCol)
    
89.                 End If
    
90.             End If
    
91.             If (bDownSort And vVal(1) >= vVal(2)) Or (Not bDownSort And vVal(1) <= vVal(2)) Then '符合指定排序时，交换记录已经比较到哪行
    
92.                 If nRow > nJ Then
    
93.                     nJ = nRow
    
94.                 Else
    
95.                     nRow = nJ
    
96.                 End If
    
97.             Else '不符合指定排序时，交换当前行与下一行数值
    
98.                 If nDimension = 1 Then
    
99.                     vTmp = vData(nRow)
    
100.                     vData(nRow) = vData(nRow + 1)
     
101.                     vData(nRow + 1) = vTmp
     
102.                 Else
     
103.                     For nCol = LBound(vData, 2) To UBound(vData, 2)
     
104.                         vTmp = vData(nRow, nCol)
     
105.                         vData(nRow, nCol) = vData(nRow + 1, nCol)
     
106.                         vData(nRow + 1, nCol) = vTmp
     
107.                     Next
     
108.                 End If
     
109.                 If nRow <> LBound(vData) Then nRow = nRow - 2
     
110.             End If
     
111.         Next nRow
     
112.     End If
     
113.     VariantSort = vData '返回结果
     
114. End Function

复制代码

二维（以下）数组排序的自定义函数(By.Micro).rar (42.9 KB, 下载次数: 228)

2019-6-14 11:50 上传

点击文件名下载附件

不知道为什么

microyip 老师大作，收藏了！

pnzt

学习学习学习学习

鄂龙蒙

对2维数组排序非常头痛，学习大师的作品很有帮助，测试中加入重复数据排序好像有点问题，请老师帮助一下。谢谢！

鄂龙蒙

附件不知为什么上传不了。

zopey

1. Function compare(a, b)
   
2. typea = VarType(a)
   
3. If typea = 10 Then compare = 2: Exit Function
   
4. 
   
5. '比较数据类型 是否相同
   
6. If VarType(b) = typea Then
   
7.    Select Case typea
   
8.        Case 5
   
9.            If a = b Then
   
10.               compare = 0
    
11.            ElseIf a < b Then
    
12.               compare = -1
    
13.            Else
    
14.               compare = 1
    
15.            End If
    
16.        Case 11
    
17.            If a = b Then
    
18.               compare = 0
    
19.            ElseIf a > b Then
    
20.               compare = -1
    
21.            Else
    
22.               compare = 1
    
23.            End If
    
24.        Case 8
    
25.            '文本比较， vbTextCompare =不区分字母大小写
    
26.            compare = StrComp(a, b, vbTextCompare)
    
27.    End Select
    
28. Else
    
29.    compare = 4
    
30. End If
    
31. End Function

复制代码

比较任意2个元素的大小，类型不同 可能无法比较。

microyip

zopey 发表于 2019-6-14 16:07
比较任意2个元素的大小，类型不同 可能无法比较。

这是什么意思啊？没看明白

zopey

函数  StrComp(string1, string2, [ compare ])返回字符串比较的结果：
string1 小于 string2  返回 -1，string1 等于 string2  返回 0，string1 大于 string2  返回 1。

在此基础上，我写的增强函数，可以比较 多种类型数据的 大小，可用于混合数据排序。

microyip

zopey 发表于 2019-6-14 16:21
函数  StrComp(string1, string2, [ compare ])返回字符串比较的结果：
string1 小于 string2  返回 -1 ...

哦，强，努力！