VBA_自定义排序学习记录

一直想学下自定义排序，之前有了解到sort方法排序和一个个对比的排序方法，今天遇到个需要按固定顺序来排序的问题，所以一时兴起就去网上找了下答案。

排序后结果

代码片段:

Sub order_by_customize()
    Dim ws As Worksheet
    Dim arr(), brr()
    Dim d As Object
    Dim r(), i&, j&, k&, ra As Range
    Set ws = ActiveWorkbook.Worksheets("排序测试")
    Set d = CreateObject("scripting.dictionary")
     
    j = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    i = ws.Cells(Rows.Count, "B").End(xlUp).Row
    '将目标自定义排序列数据写入数组,这里我把指定序列 先放到B列下面空白的地方了
    r() = ws.Range("B21:B" & i).Value
     
    k = 1
    '自定义排序的数组写入字典，序号作为item
    For k = 1 To UBound(r())
        d(r(k, 1)) = k
    Next
     
    i = ws.Cells(Rows.Count, 1).End(xlUp).Row
    '数据源写入数组
    arr() = ws.Range(ws.Cells(2, 1), ws.Cells(i, j)).Value
     
    '创建另一个数组,用来记录排序的序列号
    ReDim brr(1 To UBound(arr()), 1 To 1)
     
    k = 1
    For k = 1 To UBound(arr())
        '将自定义排序的序号写入数组brr, 我想要排序的被排序的列在第1列
        If d.exists(arr(k, 1)) Then
 
            brr(k, 1) = d(arr(k, 1))
        Else
            brr(k, 1) = "指定序列不存在"
        End If
    Next k
     
    '将新的序号放在最后一列
    ws.Cells(2, j + 1).Resize(UBound(brr()), 1) = brr
     
    Set ra = ws.Range(ws.Cells(1, 1), ws.Cells(i, j + 1))
     
    'sort方法排序
    ra.Sort key1:=ws.Cells(2, j + 1), order1:=xlAscending, Header:=xlYes
     
    '删除辅助排序的列
    ws.Range(ws.Cells(1, j + 1), ws.Cells(i, j + 1)).Delete
     
    Set d = Nothing
 
End Sub