[Excel VBA]自定义排序的三种方法

Dear 丶 2021-11-05 09:44 434阅读 0赞

诸君好，前前期我们聊了VBA编程和数据的常规排序……VBA常用小代码105：Rang对象的排序操作……  
今天我们再聊下自定义排序……  
何谓自定义排序，就是按指定的顺序对数据源进行排序呗……  
  
今一共分享了三种方法。  
第1种方法是系统自带的OrderCustom，优点是代码简洁，缺点是自定义序列有字符长度限制（255个）。  
第2种方法是字典+数组设置序列号，再使用了辅助列进行排序。优点是不会破坏单元格的形式和结构，比如单元格中存在的公式、背景等。  
第3种方法是只使用字典+数组，借助简单桶排序的技巧，直接对数据在数组中进行排序。优点是效率较高，缺点是会破坏单元格的结构，比如消除公式等。  
（第1种建议掌握，第2种建议了解，第3种……能懂就懂，不懂先放着吧~）  
  
举个例子。  
如下图所示，A:C列是数据源。  
现需要根据E列所指定的部门先后顺序，对数据源进行重新排序，如果部门不在指定序列内，则排放在数据源末尾。  
![3-1Z106154F15I.png][]  
排序结果如下图。  
![3-1Z106154G2409.png][]  
  
**第1种方法代码如下：**

> Sub FreeSort()  
> 'eh技术论坛 VBA编程学习与实践 看见星光  
> Dim n&, rng As Range  
> Set rng = Range("e2:e" & Cells(Rows.Count, "e").End(xlUp).Row)  
> Application.AddCustomList (rng)  
> '增加一个自定义序列,该参数除了支持单元格对象，也支持数组。  
> n = Application.CustomListCount  
> '自定义序列的数目  
> Range("a:c").Sort key1:=\[a1\], order1:=xlAscending, Header:=xlYes, ordercustom:=n + 1  
> '使用自定义排序，ordercustom指定使用哪个自定义序列排序。  
> '当使用自定义排序时，需要将OrderCustom参数设置为指定的序列在自定义列表中的顺序加1  
> Application.DeleteCustomList n  
> '删除新增的自定义序列  
> End Sub

**第2种方法代码如下：**

> Sub DicSort()  
> Dim d As Object, r, i&, arr, brr  
> Set d = CreateObject("ing.dictionary")  
> r = Range("e2:e" & Cells(Rows.Count, "e").End(xlUp).Row).Value  
> For i = 1 To UBound(r)  
> d(r(i, 1)) = i '目标序列循环装入字典，序号作为item  
> Next  
> arr = Range("a2:c" & Cells(Rows.Count, 1).End(xlUp).Row)  
> '数据源装入数组arr  
> ReDim brr(1 To UBound(arr), 1 To 1)  
> '声明数组brr装原部门在指定序列中的序号  
> For i = 1 To UBound(arr)  
> If d.exists(arr(i, 1)) Then  
> brr(i, 1) = d(arr(i, 1)) '将原部门在指定序列中的序列号装入brr  
> Else  
> brr(i, 1) = "指定序列不存在"  
> End If  
> Next  
> \[d:d\].Insert  
> '在D列插入一列  
> \[d2\].Resize(UBound(brr), 1) = brr  
> '新的序列号放入D列  
> Range("a:d").Sort key1:=\[d1\], order1:=xlAscending, Header:=xlYes 'D列升序排序  
> \[d:d\].Delete '删除D列  
> Set d = Nothing  
> End Sub

**第3种方法代码如下：**

> Sub DicArrSort()  
> 'eh技术论坛公众号 VBA编程学习与实践 看见星光  
> Dim d As Object, i&, n&, x&, k&, j&  
> Dim r, arr, brr, crr  
> Set d = CreateObject("ing.dictionary")  
> '后期绑定字典  
> r = Range("e2:e" & Cells(Rows.Count, "e").End(xlUp).Row).Value  
> For i = 1 To UBound(r)  
> d(r(i, 1)) = i '目标序列循环装入字典，序号作为item  
> Next  
> arr = Range("a2:c" & Cells(Rows.Count, 1).End(xlUp).Row)  
> '数据源装入数组  
> ReDim brr(1 To d.Count + 1, 1 To 1)  
> 'brr数组用于按序号装数组arr的行号，类似于桶排序的桶  
> For i = 1 To UBound(arr)  
> If d.exists(arr(i, 1)) Then  
> '如果字典中存在相关部门……  
> n = d(arr(i, 1))  
> '该部门在指定序列中的序号  
> brr(n, 1) = brr(n, 1) & "," & i  
> '将该部门在arr中的行号装入数组brr对应的序号行  
> Else  
> brr(UBound(brr), 1) = brr(UBound(brr), 1) & "," & i  
> '如果字典中不存在，放入数组brr最后一行  
> End If  
> Next  
> ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))  
> '数组crr放排序后的结果  
> For i = 1 To UBound(brr)  
> If brr(i, 1) <> "" Then  
> '如果不为空，则有符合指定排序条件的关键词  
> r = Split(brr(i, 1), ",")  
> '将brr该位置储存的行号取出  
> For x = 1 To UBound(r)  
> k = k + 1 '累加行  
> For j = 1 To UBound(arr, 2)  
> crr(k, j) = arr(r(x), j)  
> '遍历指定行位置数组arr的值移到crr  
> Next  
> Next  
> End If  
> Next  
> Range("a2:c" & Cells(Rows.Count, 1).End(xlUp).Row) = crr  
> '将数组crr排序后的结果放回单元格区域  
> Set d = Nothing '释放字典  
> Erase arr: Erase brr: Erase crr  
> '释放数组  
> End Sub

题外话：  
之前我们讲过，数组和字典是VBA处理数据的最佳利器，这是由于数组可以提高计算效率，字典可以关联多个数据源构建各种关系，因此这里再次对学习VBA的童鞋们提个小建议，不要在单元格工作簿等对象上浪费太多时间，那是熟能生巧的事物，数组和字典才是学习VBA的核心要义哦。

转载于:https://www.cnblogs.com/medik/p/11026422.html

[3-1Z106154F15I.png]: /images/20211104/879b51451e4242dd85c1c81a3d18072b.png
[3-1Z106154G2409.png]: /images/20211104/397e0d3a9c5c46619529113a7427eb0f.png