Excel VBA：指定された初期値が設定された Dictionary を作成して返す関数／Dictionary の値をまとめて更新する関数

0.README.md

[Excel] 任意のキー／値の組み合わせで Dictionary を初期化／更新する VBA プロシージャ

ソースコード

1. CreateDictionary.vba

CreateDictionary.vba

Option Explicit

Function CreateDictionary(ParamArray ParamList() As Variant) As Object
'   指定された初期値が設定された Dictionary を作成して返す
'
'   ■引数
'     ParamList
'       以下のいずれかを指定
'       - key1, value1, key2, value2, ... のようなキーと値の羅列
'       - Array(key1, value1, key2, value2, ... )のような配列
'       - 1列目がキー・2列目が値となるような矩形 Range
'       ※ key / value は文字列もしくは数値のみ、key として空文字を指定しないこと
'
'   ■戻り値
'       作成した Dictionary

    Set CreateDictionary = UpdateDictionary(Nothing, ParamList)
End Function

Function UpdateDictionary(ByRef TargetDictionary As Object, ParamArray ParamList() As Variant) As Object
'   対象 Dictionary を指定された値で更新
'
'   ■引数
'     TargetDictionary
'       更新対象となる Dictionary
'       ※ Nothing の場合は新規作成されるが、これは CreateDictionary() から呼び出される場合のみを想定しているため、
'          通常の更新の際には Nothing は指定しないこと
'
'     ParamList
'       以下のいずれかを指定
'       - key1, value1, key2, value2, ... のようなキーと値の羅列
'       - Array(key1, value1, key2, value2, ... )のような配列（※ ParamList(1) 以降は無視）
'       - 1列目がキー・2列目が値となるような矩形 Range（※ ParamList(1) 以降は無視）
'       ※ key / value は文字列もしくは数値のみ、key として空文字を指定しないこと
'       ※ CreateDictionary()から呼ばれると（＝TargetDictionary が Nothing の場合）、ParamList(0) に CreateDictionary() の引数（ParamList）が入ることに注意
'
'   ■戻り値
'       TargetDictionary で指定された Dictionary (Nothing の場合、新規に作成した Dictionary）

    Dim KeyValueList As Variant
    Dim Param As Variant
    Dim Key As Variant
    Dim IsValue As Boolean
    Dim KeyValueParams() As Variant
    Dim FirstIndex As Long: FirstIndex = LBound(ParamList)
    Dim LastIndex As Long: LastIndex = UBound(ParamList)
    Dim ParamNumber As Long: ParamNumber = LastIndex - FirstIndex + 1
    Dim IsCreated As Boolean
    
    If TargetDictionary Is Nothing Then
        Set TargetDictionary = CreateObject("Scripting.Dictionary")
        IsCreated = True
    End If
    
    Set UpdateDictionary = TargetDictionary
    
    If ParamNumber <= 0 Then Exit Function ' 引数無しの場合はそのまま返す
    
    If IsCreated Then
        ' CreateDictionaryより呼ばれた場合を想定
        KeyValueParams = ParamList(FirstIndex)
        
        FirstIndex = LBound(KeyValueParams)
        LastIndex = UBound(KeyValueParams)
        ParamNumber = LastIndex - FirstIndex + 1
       
        If ParamNumber <= 0 Then Exit Function ' 引数無しの場合はそのまま返す
    Else
        KeyValueParams = ParamList
    End If
    
    ' 第1引数の型により場合分け
    If IsObject(KeyValueParams(FirstIndex)) Then
        ' Object の場合（Range のみを想定）
        On Error Resume Next
        KeyValueList = WorksheetFunction.Transpose(KeyValueParams(FirstIndex).Value)
        On Error GoTo 0
        If IsEmpty(KeyValueList) Then Exit Function
    ElseIf IsArray(KeyValueParams(FirstIndex)) Then
        ' 配列の場合
        KeyValueList = KeyValueParams(FirstIndex)
    Else
        ' key1, value1, key2, value2, ... となるような引数の場合
        KeyValueList = KeyValueParams
    End If
    
    For Each Param In KeyValueList
        If IsValue Then
            ' Dictionary に追加（同一キーの場合上書き）
            TargetDictionary(Key) = Param
        Else
            If Param = "" Then GoTo NEXT_PARAM ' 空のものは無視（※主に 0 Origin の配列を 1 から使用しているような場合を想定）
            ' キーを保持
            Key = Param
        End If
        IsValue = Not IsValue
NEXT_PARAM:
    Next
    
    If IsValue Then TargetDictionary(Key) = Empty
End Function

Sub ShowDictionary(ByRef TargetDictionary As Object)
    Dim Key As Variant
    Dim LeftStr As String, RightStr As String
    
    For Each Key In TargetDictionary
        LeftStr = IIf(VarType(Key) = vbString, """" & Key & """", CStr(Key))
        RightStr = IIf(VarType(TargetDictionary(Key)) = vbString, """" & TargetDictionary(Key) & """", CStr(TargetDictionary(Key)))
        Debug.Print LeftStr & " : " & RightStr
    Next
    
    Debug.Print ""
End Sub

Sub Test()
    Dim Dic As Dictionary
    
    Debug.Print "-- キーと値の羅列で指示"
    Set Dic = CreateDictionary("key1", 1, 2, "value2")
    ShowDictionary Dic
    
    Debug.Print "-- String 型の配列で指示"
    Dim StrArray(4) As String
    StrArray(1) = "k1"
    StrArray(2) = "v1"
    StrArray(3) = "k2"
    StrArray(4) = "v2"
    Set Dic = CreateDictionary(StrArray)
    ShowDictionary Dic
    
    Debug.Print "-- Split() で分割した配列で指示"
    Set Dic = CreateDictionary(Split("K1,V1,K2,V2,K3,V3", ","))
    ShowDictionary Dic
    
    Debug.Print "-- Array で指示"
    Set Dic = CreateDictionary(Array("a", 1, "b", 2, "c", 3))
    ShowDictionary Dic
    
    Debug.Print "-- Range で指示"
    Set Dic = CreateDictionary(Range("A1").Resize(3, 2))
    ShowDictionary Dic
    
    Debug.Print "--- キーと値の羅列で更新"
    Call UpdateDictionary(Dic, "key1", "V1", "key4", 4)
    ShowDictionary Dic

    Debug.Print "-- String 型の配列で更新"
    Call UpdateDictionary(Dic, StrArray)
    ShowDictionary Dic
    
    Debug.Print "-- Split() で分割した配列で更新"
    Call UpdateDictionary(Dic, Split("k1,V1,K2,V2,K3,V3", ","))
    ShowDictionary Dic
    
    Debug.Print "-- Array で更新"
    Call UpdateDictionary(Dic, Array("key1", 1, "a", 2, "b", 3))
    ShowDictionary Dic
    
    Debug.Print "-- Rangeで更新"
    Call UpdateDictionary(Dic, Range("A4").Resize(3, 2))
    ShowDictionary Dic
End Sub

Mod_MultiSet.vba

Option Explicit

Property Let MultiSet(ParamArray Vars(), ByVal Values)
    Dim LbVars, UbVars: LbVars = LBound(Vars): UbVars = UBound(Vars)
'    If UbVars - LbVars + 1 = 1 Then Values = Array(Values)
    ReDim Preserve Values(LbVars To UbVars)
    Dim Index
    For Index = LbVars To UbVars
        Select Case True
            Case IsObject(Values(Index)), VarType(Values(Index)) = vbDataObject: Set Vars(Index) = Values(Index)
            Case Else: Vars(Index) = Values(Index)
        End Select
    Next
End Property

Mod_SetDict.vba

Option Explicit

Property Let SetDict(TargetDict, ParamArray Vars(), ByVal Values)
    Dim LbVars, UbVars: LbVars = LBound(Vars): UbVars = UBound(Vars)
'    If UbVars - LbVars + 1 = 1 Then Values = Array(Values)
    ReDim Preserve Values(LbVars To UbVars)
    Dim Index
    If TypeName(TargetDict) = "Collection" Then
        For Index = LbVars To UbVars: TargetDict.Add Values(Index), Key:=Vars(Index): Next
    Else
        For Index = LbVars To UbVars: TargetDict.Add Vars(Index), Values(Index): Next
    End If
End Property

Sub TestSetDict()
    Dim Col As Collection: Set Col = New Collection: SetDict(Col, "a", "b", "c") = Array(1, 2, 3)
    Debug.Print Col("a"), Col("b"), Col("c")
    Dim Dict: Set Dict = CreateObject("Scripting.Dictionary"): SetDict(Dict, "a", "b", "c") = Array(1, "B", New Collection)
    Debug.Print Dict("a"), Dict("b"), TypeName(Dict("c"))
End Sub

• 元ネタツイート1（@excelspeedup）
• 元ネタツイート2（@furyutei）

PropertyとParamArrayの組み合わせで自然な感じで書く方法（MultiSet() / SetDict()）

• 元ネタツイート（やまと@yamato_1413さん）