[原創] 依自訂清單穩定排序模組

linyancheng

分享原創代碼（不喜中文代碼，請自行轉成英文）
----------------------------------------------------------
S_依自訂清單穩定排序模組_01.bas
----------------------------------------------------------
Option Explicit

Public Sub S_一維陣列依自訂清單穩定排序_01(ByRef 原始一維陣列 As Variant, ByVal 起限 As Long, ByVal 迄限 As Long, ByVal 自訂清單陣列 As Variant)

    On Error Resume Next
   
    If 起限 >= 迄限 Then
        Exit Sub
    End If
   
    '------------------------------------------------------
   
    Dim X As Long
   
    Dim 索引陣列() As Long
   
    '------------------------------------------------------
   
    ReDim 索引陣列(起限 To 迄限) As Long
   
    '------------------------------------------------------
   
    一維陣列依自訂清單穩定排序 原始一維陣列, 索引陣列, 起限, 迄限, 自訂清單陣列
   
    '------------------------------------------------------
   
    Dim 複製原始一維陣列 As Variant
   
    複製原始一維陣列 = 原始一維陣列
   
    For X = 起限 To 迄限
        原始一維陣列(X) = 複製原始一維陣列(索引陣列(X))
    Next X

End Sub

Public Sub S_二維陣列依自訂清單穩定排序_01(ByRef 原始二維陣列 As Variant, ByVal 排序維度 As Long, ByVal 排序鍵值 As Long, ByVal 起限 As Long, ByVal 迄限 As Long, ByVal 自訂清單陣列 As Variant)

    On Error Resume Next
   
    If 起限 >= 迄限 Then
        Exit Sub
    End If
   
    '------------------------------------------------------
   
    Dim X As Long
    Dim Y As Long
   
    Dim 擷取成一維陣列 As Variant
    Dim 索引陣列() As Long
   
    '------------------------------------------------------
   
    ReDim 擷取成一維陣列(起限 To 迄限) As Variant
    ReDim 索引陣列(起限 To 迄限) As Long
   
    If 排序維度 = 1 Then
        For X = 起限 To 迄限
            擷取成一維陣列(X) = 原始二維陣列(X, 排序鍵值)
        Next X
    Else
        For Y = 起限 To 迄限
            擷取成一維陣列(Y) = 原始二維陣列(排序鍵值, Y)
        Next Y
    End If
   
    '------------------------------------------------------
   
    一維陣列依自訂清單穩定排序 擷取成一維陣列, 索引陣列, 起限, 迄限, 自訂清單陣列
   
    '------------------------------------------------------
   
    Dim 複製原始二維陣列 As Variant
   
    複製原始二維陣列 = 原始二維陣列
   
    If 排序維度 = 1 Then
        For X = 起限 To 迄限
            For Y = LBound(原始二維陣列, 2) To UBound(原始二維陣列, 2)
                原始二維陣列(X, Y) = 複製原始二維陣列(索引陣列(X), Y)
            Next Y
        Next X
    Else
        For Y = 起限 To 迄限
            For X = LBound(原始二維陣列, 1) To UBound(原始二維陣列, 1)
                原始二維陣列(X, Y) = 複製原始二維陣列(X, 索引陣列(Y))
            Next X
        Next Y
    End If

End Sub

Private Sub 一維陣列依自訂清單穩定排序(ByRef 原始一維陣列 As Variant, ByRef 索引陣列() As Long, ByVal 起限 As Long, ByVal 迄限 As Long, ByVal 自訂清單陣列 As Variant)

    On Error Resume Next
   
    Dim X As Long
    Dim N As Long
   
    '------------------------------------------------------
   
    Dim 自訂清單字典 As Object
   
    Set 自訂清單字典 = CreateObject("Scripting.Dictionary")
   
    For X = LBound(自訂清單陣列) To UBound(自訂清單陣列)
        自訂清單字典(自訂清單陣列(X)) = 0
    Next X
   
    自訂清單陣列 = 自訂清單字典.Keys
   
    '------------------------------------------------------
   
    For X = 起限 To 迄限
        If 自訂清單字典.Exists(原始一維陣列(X)) = True Then
            自訂清單字典(原始一維陣列(X)) = 自訂清單字典(原始一維陣列(X)) + 1
            索引陣列(X) = 自訂清單字典(原始一維陣列(X))
        Else
            自訂清單字典("Key_Not_Exist") = 自訂清單字典("Key_Not_Exist") + 1
            索引陣列(X) = 自訂清單字典("Key_Not_Exist")
        End If
    Next X
   
    '------------------------------------------------------
   
    Dim 自訂清單累積數陣列 As Variant
    Dim 自訂清單累積數字典 As Object
   
    自訂清單累積數陣列 = 自訂清單字典.Items
   
    Set 自訂清單累積數字典 = CreateObject("Scripting.Dictionary")
   
    自訂清單累積數字典(自訂清單陣列(0)) = 0
   
    N = 0
    For X = 1 To UBound(自訂清單陣列)
        自訂清單累積數字典(自訂清單陣列(X)) = 自訂清單累積數陣列(N)
        N = N + 1
        自訂清單累積數陣列(N) = 自訂清單累積數陣列(N - 1) + 自訂清單累積數陣列(N)
    Next X
   
    自訂清單累積數字典("Key_Not_Exist") = 自訂清單累積數陣列(N)
   
    '------------------------------------------------------
   
    For X = 起限 To 迄限
        If 自訂清單字典.Exists(原始一維陣列(X)) = True Then
            索引陣列(X) = 索引陣列(X) + 自訂清單累積數字典(原始一維陣列(X))
        Else
            索引陣列(X) = 索引陣列(X) + 自訂清單累積數字典("Key_Not_Exist")
        End If
    Next X
   
    '------------------------------------------------------
   
    Dim 索引陣列副本 As Variant
   
    索引陣列副本 = 索引陣列
   
    For X = 起限 To 迄限
        索引陣列(起限 - 1 + 索引陣列副本(X)) = X
    Next X

End Sub

linyancheng

測試檔案