【Excel VBA】自定义排序的三种方法

时常想起过去的温存 它让我在夜里不会冷 你说一个人的美丽是认真 两个人能在一起是缘份……

梦一场 萧敬腾 - 爱的时刻自选辑

嗨，我是星光，本期副文里我们聊了如何使用VBA代码对表格中的数据进行常规排序……

这篇我们再聊下自定义排序……

何谓自定义排序，就是按指定的顺序对数据源进行排序呗……

今一共分享了三种方法。

第1种方法是系统自带的OrderCustom，优点是代码简洁，缺点是自定义序列有字符长度限制（255个）。

第2种方法是字典+数组设置序列号，再使用了辅助列进行排序。优点是不会破坏单元格的形式和结构，比如单元格中存在的公式、背景等。

第3种方法是只使用字典+数组，借助简单计数排序的技巧，直接对数据在数组中进行排序。优点是效率较高，缺点是会破坏单元格的结构，比如消除公式等。

第1种建议掌握，第2种建议了解，第3种……能懂就懂，不懂先放着吧~

我举个例子。

如下图所示，A:C列是数据源。

现需要根据E列所指定的部门先后顺序，对数据源进行重新排序，如果部门不在指定序列内，则排放在数据源末尾

排序结果如下图。

第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    ActiveSheet.Sort.SortFields.Clear '清除排序痕迹，避免删除自定义规则后保存出错    Application.DeleteCustomList n    '删除新增的自定义序列End Sub

第2种方法代码如下▼

代码解析见注释
如看不全，可以左右拖动...

Sub DicSort()    Dim d As Object, r, i&, arr, brr    Set d = CreateObject('scripting.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 = NothingEnd Sub

第3种方法代码如下▼

代码解析见注释
如看不全，可以左右拖动...

Sub DicArrSort()    'eh技术论坛公众号 VBA编程学习与实践 看见星光    Dim d As Object, i&, n&, x&, k&, j&    Dim r, arr, brr, crr    Set d = CreateObject('scripting.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的核心要义哦。

……拥抱，致安；挥手，再贱…………