Windows 10 Pro_x64 + Excel2013_x86 VBA で Dictionary を辞書順にソートする
Windows 10 Pro_x64 + Excel2013_x86 VBA で Dictionary を辞書順にソートする
基本的に、AarrayList を参照後、keyを突っ込んで sort することが多いんだけど
参照に制限が付いた気がするので、Dictionaryで代用できるようにする
※.Net Library 3.5 まで参照可ってソースが見つからない
※ソートはMSのサイトにあった気がするんだが、消えているんだよなぁ・・・
参考にしたのは以下のサイト
VBAでDictionary（連想配列）を辞書順にソートする
・Option Explicit が通るコードに修正
・可変長配列の切り方を修正
・その他、自分なりのコメントを追加
・UserFormを1個追加する
・CommandButtonを1個追加する
・２次元の文字型の配列で動作することも確認する
※For Each key In dic -> Doc.Keys で取る必要はなかったのか・・・
Option ExplicitPrivate Sub CommandButton1_Click()
'
Dim key As Variant
Dim dic As Object
Dim output As String
'
Set dic = CreateObject("Scripting.Dictionary")
'
dic("g") = "gggg"
dic("9") = "999"
dic("を") = "をををを"
dic("4") = "444"
dic("あ") = "ああああ"
dic("(") = "(((("
dic("a") = "aaaa"
'
output = "##before" & vbNewLine
For Each key In dic
output = output & key & ":" & dic(key) & vbNewLine
Next key
'
Call DicSort(dic)
'
output = output + "##after" & vbNewLine
For Each key In dic
output = output & key & ":" & dic(key) & vbNewLine
Next key
'
MsgBox output
'
' 文字型の２次元配列のソート
'
Dim typArry(3, 1) As String
Dim i As Integer
'
' 配列の添え字の最小値は０
' typArry(0, 0)〜typArry(3, 1)
'
typArry(0, 0) = "01"
typArry(0, 1) = "北海道"
typArry(1, 0) = "02"
typArry(1, 1) = "青森県"
typArry(2, 0) = "03"
typArry(2, 1) = "岩手県"
typArry(3, 0) = "01"
typArry(3, 1) = "北海道"
'
Call QuickSort(typArry, LBound(typArry), UBound(typArry))
'
For i = LBound(typArry) To UBound(typArry)
Debug.Print typArry(i, 0), typArry(i, 1)
Next
'
End Sub'=================================================================
' 名 称 : DicSort
' 機 能 : 引数のDictionaryをソートする破壊的プロシージャ
' パラメータ : Dictionary
'=================================================================
Sub DicSort(ByRef dic As Scripting.Dictionary)
'
Dim key As Variant
Dim varTmp() As String
Dim dicSize As Long
Dim lngCnt As Long
'
dicSize = dic.count
'
' QuickSort関数 で varTmp(Int(i + j / 2))との比較が発生する
' ため配列のサイズは dicSize * 2 とする
'
ReDim varTmp(dicSize * 2, 2)
'
' Dictionaryが空か、サイズが1以下であればソート不要
'
If dic Is Nothing Or dicSize < 2 Then
Exit Sub
End If
'
' Dictionaryから二元配列に転写
'
lngCnt = 0
For Each key In dic
varTmp(lngCnt, 0) = key
varTmp(lngCnt, 1) = dic(key)
lngCnt = lngCnt + 1
Next
'
' クイックソート
'
Call QuickSort(varTmp, 0, dicSize - 1)
'
dic.RemoveAll
'
For lngCnt = 0 To dicSize - 1
dic(varTmp(lngCnt, 0)) = varTmp(lngCnt, 1)
Next
'
End Sub'=================================================================
' 名 称 : QuickSort
' 機 能 : String型の二次元配列を受け取り
' :これの一列目でクイックソートする
' パラメータ : targetVar() : 二次元配列
' : min, max : ソート対象
'=================================================================
Private Sub QuickSort(ByRef targetVar() As String, ByVal min As Long, ByVal max As Long)
'
Dim i, j As Long
Dim tmp As String
Dim pivot As String
If min < max Then
i = min
j = max
pivot = Med3(targetVar(i, 0), targetVar(Int(i + j / 2), 0), targetVar(j, 0))
Do
Do While StrComp(targetVar(i, 0), pivot) < 0
i = i + 1
Loop
Do While StrComp(pivot, targetVar(j, 0)) < 0
j = j - 1
Loop
If i >= j Then Exit Do
tmp = targetVar(i, 0)
targetVar(i, 0) = targetVar(j, 0)
targetVar(j, 0) = tmp
tmp = targetVar(i, 1)
targetVar(i, 1) = targetVar(j, 1)
targetVar(j, 1) = tmp
i = i + 1
j = j - 1
Loop
Call QuickSort(targetVar, min, i - 1)
Call QuickSort(targetVar, j + 1, max)
End If
End Sub'=================================================================
' 名 称 : Med3
' 機 能 : String型のx, y, z を辞書順比較し二番目のものを返す
'=================================================================
Private Function Med3(ByVal x As String, ByVal y As String, ByVal z As String) As String
'
If StrComp(x, y) < 0 Then
If StrComp(y, z) < 0 Then
Med3 = y
ElseIf StrComp(z, x) < 0 Then
Med3 = x
Else
Med3 = z
End If
Else
If StrComp(z, y) < 0 Then
Med3 = y
ElseIf StrComp(x, z) < 0 Then
Med3 = x
Else
Med3 = z
End If
End If
End Function
