|
HI，大家好，我是星光。 今天给大家聊一下如何使用VBA代码实现自定义规则排序。 一共有三种方法，一个比一个难，也各有优缺点。 第1种方法是系统自带的OrderCustom语句，优点是代码简洁，缺点是自定义序列有字符长度限制（255个）。 第2种方法是字典+数组，借助辅助列进行排序。优点是不会破坏单元格的各种属性，比如公式、填充色、数据验证等，缺点是毕竟用了辅助列，空间处理上需要注意下。 第3种方法还是字典+数组，借助计数排序的技巧，直接对数据在数组中进行排序。优点是效率较高，缺点是会破坏单元格除了值以外的属性，比如删除了公式、背景填充色等。 第1种建议掌握，第2种建议了解，第3种……能懂就懂，不懂先放着吧~ …… 举个例子。 如下图所示，A:C列是数据源。  现需要根据E列所指定的部门先后顺序，对数据源进行重新排序，如果部门不在指定序列内，则排放在数据源末尾。
1, 调用系统自定义排序功能 代码解析见注释 代码看不全可以左右拖动..▼ Sub FreeSort() Dim rng As Range, n As Long Set rng = Range('e2:e' & Cells(Rows.Count, 'e').End(xlUp).Row) '自定义排序的规则 Application.AddCustomList (rng) '增加一个自定义序列。 n = Application.CustomListCount '自定义序列的数目+1 Range('a:c').Sort key1:=Range('a1'), _ order1:=xlAscending, _ Header:=xlYes, _ ordercustom:=n + 1 '按指定序列排序 ActiveSheet.Sort.SortFields.Clear '清除排序痕迹，避免删除自定义规则后保存出错 Application.DeleteCustomList nEnd Sub2, 辅助列解法 代码看不全可以左右拖动..▼
3, 计数排序 代码看不全可以左右拖动..▼ Sub DicArrSort() 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
|
|
|
