標題: [原創] 依自訂清單穩定排序模組 [打印本頁]

---

作者: linyancheng    時間: 2022-4-3 20:10     標題: 依自訂清單穩定排序模組

本帖最後由 linyancheng 於 2026-2-21 16:42 編輯

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

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

    On Error Resume Next
   
    If IsMissing(起限) Or Not IsNumeric(起限) Then
        起限 = LBound(原始一維陣列)
    Else
        起限 = Fix(起限)
        
        If 起限 < LBound(原始一維陣列) Then
            起限 = LBound(原始一維陣列)
        End If
    End If
   
    If IsMissing(迄限) Or Not IsNumeric(迄限) Then
        迄限 = UBound(原始一維陣列)
    Else
        迄限 = Fix(迄限)
        
        If 迄限 > UBound(原始一維陣列) Then
            迄限 = UBound(原始一維陣列)
        End If
    End If
   
    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, Optional ByVal 起限 As Variant, Optional ByVal 迄限 As Variant, Optional ByVal 自訂清單陣列 As Variant)

    On Error Resume Next
   
    If IsMissing(起限) Or Not IsNumeric(起限) Then
        起限 = LBound(原始二維陣列, 排序維度)
    Else
        起限 = Fix(起限)
        
        If 起限 < LBound(原始二維陣列, 排序維度) Then
            起限 = LBound(原始二維陣列, 排序維度)
        End If
    End If
   
    If IsMissing(迄限) Or Not IsNumeric(迄限) Then
        迄限 = UBound(原始二維陣列, 排序維度)
    Else
        迄限 = Fix(迄限)
        
        If 迄限 > UBound(原始二維陣列, 排序維度) Then
            迄限 = UBound(原始二維陣列, 排序維度)
        End If
    End If
   
    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 Variant
    Dim 自訂清單數量字典 As Object
   
    ReDim 不重複自訂清單陣列(0 To UBound(自訂清單陣列) - LBound(自訂清單陣列)) As Variant
   
    Set 自訂清單數量字典 = CreateObject("Scripting.Dictionary")
   
    N = -1
    For X = LBound(自訂清單陣列) To UBound(自訂清單陣列)
        If Not 自訂清單數量字典.Exists(自訂清單陣列(X)) Then
            N = N + 1
            不重複自訂清單陣列(N) = 自訂清單陣列(X)
            自訂清單數量字典(自訂清單陣列(X)) = 0 '數量初始化
        End If
    Next X
   
    ReDim Preserve 不重複自訂清單陣列(0 To N) As Variant
   
    自訂清單數量字典("Key_Not_Exist") = 0 '數量初始化
   
    '------------------------------------------------------
   
    For X = 起限 To 迄限
        If 自訂清單數量字典.Exists(原始一維陣列(X)) Then
            自訂清單數量字典(原始一維陣列(X)) = 自訂清單數量字典(原始一維陣列(X)) + 1 '相同元素的數量
            索引陣列(X) = 自訂清單數量字典(原始一維陣列(X)) '相同元素的相對次序
        Else
            自訂清單數量字典("Key_Not_Exist") = 自訂清單數量字典("Key_Not_Exist") + 1 '相同元素的數量
            索引陣列(X) = 自訂清單數量字典("Key_Not_Exist") '相同元素的相對次序
        End If
    Next X
   
    '------------------------------------------------------
   
    Dim 自訂清單累積數量字典 As Object
   
    Set 自訂清單累積數量字典 = CreateObject("Scripting.Dictionary")
   
    自訂清單累積數量字典(不重複自訂清單陣列(0)) = 0
   
    For X = 1 To UBound(不重複自訂清單陣列)
        自訂清單累積數量字典(不重複自訂清單陣列(X)) = 自訂清單累積數量字典(不重複自訂清單陣列(X - 1)) + 自訂清單數量字典(不重複自訂清單陣列(X - 1))
    Next X
   
    自訂清單累積數量字典("Key_Not_Exist") = 自訂清單累積數量字典(不重複自訂清單陣列(UBound(不重複自訂清單陣列))) + 自訂清單數量字典(不重複自訂清單陣列(UBound(不重複自訂清單陣列)))
   
    '------------------------------------------------------
   
    For X = 起限 To 迄限
        If 自訂清單數量字典.Exists(原始一維陣列(X)) Then
            索引陣列(X) = 起限 - 1 + 自訂清單累積數量字典(原始一維陣列(X)) + 索引陣列(X) '元素的陣列次序
        Else
            索引陣列(X) = 起限 - 1 + 自訂清單累積數量字典("Key_Not_Exist") + 索引陣列(X) '元素的陣列次序
        End If
    Next X
   
    '------------------------------------------------------
   
    Dim 索引陣列副本 As Variant
   
    索引陣列副本 = 索引陣列
   
    For X = 起限 To 迄限
        索引陣列(索引陣列副本(X)) = X '次序調換
    Next X

End Sub

---

作者: linyancheng    時間: 2022-4-17 10:28

測試檔案

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)