TOP ▲ itcore TOP ＞ TIPS ＞ vba_sort.php 　タグ:vba 連想配列 ソート ディクショナリ変数

VBA 連想配列 キーでソート | itcore 2019年

ソース　ExcelよりALT+F11で貼り付ける

'------------
' VBA ソート
'------------
Option Explicit
Public Sub main()
  '-----------------------------------
  ' ディクショナリ（連想配列）データ
  '-----------------------------------
  Dim obj1: Set obj1 = CreateObject("Scripting.Dictionary")
  obj1("x") = "x1"
  obj1("a") = "a1"
  obj1("b") = "b1"

  '-----------------------------------
  ' キーによるソート
  '-----------------------------------
  Dim no: no = 0
  Dim arrkey(), key
  ReDim arrkey(obj1.Count)
  For Each key In obj1
    no = no + 1
    arrkey(no) = key
  Next
  sort1 arrkey
    '-----------------------------------
  ' 画面出力
  '-----------------------------------
  For no = 1 To UBound(arrkey)
    key = arrkey(no)
    Debug.Print no, key, obj1(key)
  Next no
  End Sub

'-----------------------
' クイックソート関数
'-----------------------
Sub sort1(ByRef arrkey, Optional iFirst As Long = 0, Optional iLast As Long = -1)
    Dim iLeft As Long '// 左ループカウンタ
    Dim iRight As Long '// 右ループカウンタ
    Dim sMedian '// 中央値
    Dim tmp '// 配列移動用バッファ
        '// ソート終了位置
    If (iLast = -1) Then
        iLast = UBound(arrkey)
    End If
            '// 中央値を取得
    sMedian = arrkey(Int((iFirst + iLast) / 2))
        iLeft = iFirst
    iRight = iLast
        Do
        '// 中央値の左側をループ
        Do
            '// 配列の左側から中央値より大きい値を探す
            'If (arrkey(iLeft) >= sMedian) Then
            If StrComp(arrkey(iLeft), sMedian, 1) >= 0 Then ' テキストモードの比較（大文字・小文字を同一視）
                Exit Do
            End If
                        '// 左側を１つ右にずらす
            iLeft = iLeft + 1
        Loop
                '// 中央値の右側をループ
        Do
            '// 配列の右側から中央値より大きい値を探す
            'If (sMedian >= arrkey(iRight)) Then
            If StrComp(sMedian, arrkey(iRight), 1) >= 0 Then ' テキストモードの比較（大文字・小文字を同一視）
                Exit Do
            End If
                        '// 右側を１つ左にずらす
            iRight = iRight - 1
        Loop
                '// 左側の方が大きければここで処理終了
        If (iLeft >= iRight) Then
            Exit Do
        End If
                '// 右側の方が大きい場合は、左右を入れ替える
        tmp = arrkey(iLeft)
        arrkey(iLeft) = arrkey(iRight)
        arrkey(iRight) = tmp
                '// 左側を１つ右にずらす
        iLeft = iLeft + 1
        '// 右側を１つ左にずらす
        iRight = iRight - 1
    Loop
        '// 中央値の左側を再帰でクイックソート
    If (iFirst < iLeft - 1) Then
        Call sort1(arrkey, iFirst, iLeft - 1)
    End If
        '// 中央値の右側を再帰でクイックソート
    If (iRight + 1 < iLast) Then
        Call sort1(arrkey, iRight + 1, iLast)
    End If
    End Sub

実行結果

 1 a a1
 2 b b1
 3 x x1