【转载】EXCEL VBA 自定义排序的三种方法

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

 

共分享了三种方法：

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

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

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

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

 

举个例子。

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

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

Sub 自定义排序1()

    '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

 

Sub 自定义排序2()

    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

 

Sub 自定义排序3()

    '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