[ExcelVBA] Dictionaryオブジェクト

>Blog Top Page >[ExcelVBA] Top Page >[ExcelVBA] ExcelVBA ALL

呼び名がこれでよいのかよくわからないのだけど、ハッシュだったり連想配列とよばれているものについてのまとめ。
まずは、格納して参照する仕方から。

Option Explicit

Sub sample()
    Dim obj As Object
    Set obj = CreateObject("Scripting.Dictionary")
    obj.Add "test", 123
    
    Debug.Print obj.Item("test")
    Set obj = Nothing
End Sub

４行目：型の宣言
５行目：オブジェクトの作成
６行目：Addメソッドでキーに対する値をセット
８行目：Itemメソッドに引数にキーを渡し値を表示
オブジェクト名.Item(キー名)
※注：キーにセルの値を渡したい時、Range("A1")のように.Valueを省略すると
Rangeオブジェクトがキーに渡されて期待した動きをしません。
RangeやCellsで値を渡したい時は、Range("A1").Valueのようにする必要があります。



Add/Item以外のメソッドやプロパティは･･･
■Exists(キーが存在するか調べる)

Option Explicit

Sub sample()
    Dim obj As Object
    Set obj = CreateObject("Scripting.Dictionary")
    obj.Add "test", 123
    
    Debug.Print obj.Exists("test") 'True←存在してるキーだから
    Debug.Print obj.Exists("te") 'False←存在していないキーだから
    Set obj = Nothing
End Sub

■Key(キーを変更する)

Option Explicit

Sub sample()
    Dim obj As Object
    Set obj = CreateObject("Scripting.Dictionary")
    obj.Add "test", 123
    
    Debug.Print obj.Item("test") '123
    Debug.Print obj.Exists("testes") 'False:まだ存在していないキー
    obj.key("test") = "testes" 'testキーからtestesキーへ変更
    
    Debug.Print obj.Item("testes") '123
    Debug.Print obj.Exists("test") 'testキーは消滅
    Set obj = Nothing
End Sub

■Remove(キーを削除する)

Option Explicit

Sub sample()
    Dim obj As Object
    Set obj = CreateObject("Scripting.Dictionary")
    obj.Add "test", 123
    
    MsgBox obj.Exists("test") 'True
    obj.Remove ("test") 'testキーを削除
    Debug.Print obj.Exists("test") 'False 
    Set obj = Nothing
End Sub

■RemoveAll(全てのキーを削除)

Option Explicit

Sub sample()
    Dim obj As Object
    Set obj = CreateObject("Scripting.Dictionary")
    obj.Add "test", 123
    
    Debug.Print obj.Exists("test") 'True
    obj.RemoveAll '全てのキーを削除
    Debug.Print obj.Exists("test") 'False
    Set obj = Nothing
End Sub

■Count(キーの数を返します)

Option Explicit

Sub sample()
    Dim obj As Object
    Set obj = CreateObject("Scripting.Dictionary")
    obj.Add "test", 123
    
    Debug.Print obj.Count '１
    Set obj = Nothing
End Sub

■For Eachでキーと値を表示

Option Explicit

Sub sample()
    Dim obj As Object
    Dim key As Variant
    
    Set obj = CreateObject("Scripting.Dictionary")
    obj.Add "a", 111
    obj.Add "b", 222
    obj.Add "c", 333
    obj.Add "d", 444
    
    For Each key In obj
        Debug.Print "キー名：" & key & ", 値：" & obj.Item(key)
    Next key
    Set obj = Nothing
End Sub

■For文でキーと値を表示

Option Explicit

Sub sample()
    Dim obj As Object
    Dim i As Integer
    
    Set obj = CreateObject("Scripting.Dictionary")
    obj.Add "a", 111
    obj.Add "b", 222
    obj.Add "c", 333
    obj.Add "d", 444
    
    For i = 0 To obj.count - 1
        Debug.Print "キー名：" & obj.keys()(i) & ", 値：" & obj.Items()(i)
    Next
    Set obj = Nothing
End Sub

これらを踏まえて、以下の状況を考えてみます。
３人の生徒における４教科のテスト結果を変数に格納してる場合どうすればよいか？

ここでは、太郎、次郎、三郎の３人に対し、国語、算数、理科、社会の
４教科のそれぞれを乱数で点数を決定し値を格納し、それをdebug.printで
出力してみたいと思います。

Option Explicit

Sub SampleCode()
    Dim Score As Object, Person As Object
    Set Score = CreateObject("Scripting.Dictionary")
    
    Dim PersonalName As Variant: PersonalName = Array("太郎", "次郎", "三郎") '人名の準備
    Dim SubjectName As Variant: SubjectName = Array("国語", "算数", "理科", "社会") '科目の準備
            
    Dim i As Integer, ii As Integer
    For i = 0 To UBound(PersonalName) '人名でループ
        Set Person = CreateObject("Scripting.Dictionary") '格納する為の準備
        
        For ii = 0 To UBound(SubjectName) '人名ごとの科目でループ
            Person.Add SubjectName(ii), Int(Rnd() * 101) '科目名、点数
        Next
        
        Score.Add PersonalName(i), Person '人名, オブジェクト(科目名と点数のセット)
        Set Person = Nothing '不要になったら破棄
    Next


    '以降　出力
    Dim PersonKey As Variant, SubjectKey As Variant
    For Each PersonKey In Score 'まずは人名を取り出す
        Debug.Print "[" & PersonKey & "]"

        For Each SubjectKey In Score.Item(PersonKey)
            Debug.Print "　" & SubjectKey & "：" & Score.Item(PersonKey).Item(SubjectKey)
        Next
    Next
    
    Set Score = Nothing
End Sub

出力参考：
[太郎]
国語：87
算数：79
理科：37
社会：97
[次郎]
国語：88
算数：5
理科：95
社会：36
[三郎]
国語：53
算数：77
理科：5
社会：59

便利ですね。



■応用編(色んなObjectを組み合わせる)
もっと複雑な組み合わせにすることも可能です。
例えば、以下の情報を持ちたいとします。


今回はこういうデータ構造にしてみたいと思います。
学年をキーに、値をDictionaryにします。
そのDictionaryは、名前をキーに値をDictionaryを持ちます
そのDictionaryは、値に身長、趣味を持ち
身長は、値に数値を持ち
趣味は、値にCollectionを持つとします。

"学年" => {(Dictionary)
          名前 => {(Dictionary)
                  身長 => 数値,
                  趣味 => {(Collection) 文字列}
                  }
           }

今回は、学年内で名前は重複しないという前提にします。

Option Explicit

Sub Sample()
    Dim obj As Object
    Set obj = CreateObject("Scripting.Dictionary")
    
    Dim r As Long, EndRow As Long
    EndRow = Range("A65536").End(xlUp).Row '最終行取得
    
    Dim CellGrade As String, CellName As String, CellTall As String
    Dim CellHobby1 As String, CellHobby2 As String, CellHobby3 As String
    For r = 2 To EndRow
        '値を取得
        CellGrade = Range("A" & r)
        CellName = Range("B" & r)
        CellTall = Range("C" & r)
        CellHobby1 = Range("D" & r)
        CellHobby2 = Range("E" & r)
        CellHobby3 = Range("F" & r)
        
        '学年名が既にキーに登録されているか調べる
        If Not obj.Exists(CellGrade) Then
        '登録されていない
            '学年の登録
            obj.Add CellGrade, CreateObject("Scripting.Dictionary") '値にDictionary
        End If
        
        '名前の登録
        obj.Item(CellGrade).Add CellName, CreateObject("Scripting.Dictionary")
        '身長の登録
        obj.Item(CellGrade).Item(CellName).Add "身長", CellTall
        '趣味を登録
        obj.Item(CellGrade).Item(CellName).Add "趣味", New Collection
        If CellHobby1 <> "" Then _
            obj.Item(CellGrade).Item(CellName).Item("趣味").Add CellHobby1
        If CellHobby2 <> "" Then _
            obj.Item(CellGrade).Item(CellName).Item("趣味").Add CellHobby2
        If CellHobby3 <> "" Then _
            obj.Item(CellGrade).Item(CellName).Item("趣味").Add CellHobby3
    Next

    Set obj = Nothing
End Sub

ここで補足があります。
このように深い階層になってくると何度もItem(キー)でつないでいくことになるのですが
コードが横長になって見づらくなってしまいます。
ただし、Itemは省略することが可能なため
obj.Item(CellGrade).Item(CellName).Item("趣味").Add CellHobby1
を
obj(CellGrade)(CellName)("趣味").Add CellHobby1
と書くこともきます。

>Blog Top Page >[ExcelVBA] Top Page >[ExcelVBA] ExcelVBA ALL