- 帖子
- 219
- 主題
- 69
- 精華
- 2
- 積分
- 320
- 點名
- 0
- 作業系統
- Windows 10
- 軟體版本
- Office 2000, 2019
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 彰化縣
- 註冊時間
- 2013-7-18
- 最後登錄
- 2024-3-4
|
分享原創代碼（不喜中文代碼，請自行轉成英文）
----------------------------------------------------------
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 |
|
發表於 2022-4-3 20:10
| 
