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 Explicit

Private 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