諸君好，前前期我們聊了VBA編程和數據的常規排序……VBA常用小代碼105：Rang對象的排序操作……
今天我們再聊下自定義排序……
何謂自定義排序，就是按指定的順序對數據源進行排序唄……
今一共分享了三種方法。
第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
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的核心要義哦。