- 帖子
- 235
- 主題
- 78
- 精華
- 2
- 積分
- 345
- 點名
- 0
- 作業系統
- Windows 10
- 軟體版本
- Office 2000, 2019
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 彰化縣
- 註冊時間
- 2013-7-18
- 最後登錄
- 2026-6-1
|
本帖最後由 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 |
|
發表於 2022-4-3 20:10
| 
