自作VBAモジュール、特定のRangeをHashオブジェクトに格納するメソッドです。グループ分けのマスター／サブキーの設定も可能

自作モジュール、知る人ぞ知る、商用禁止

Option Explicit
'useage example:
'************************************************************************************
'load Microsoft scripting runtime
'dim result as Scripting.Dictionary
'set result = rg2hash(myWorksheet.Range("A2:CD255"), Array("term", "id") , True)
'************************************************************************************

'######################################################################################################################################################################################################
'rg2hash:               -- return an key formated hash that read from a certain range or Nothing if anything goes wrong
'author:                -- kagen.job$gmail.com write on 2102/2/5
'para1:rg               -- (must) an rectangle Range object to be read
'para2:keys             -- (opti - default Empty) an array of keys from main to sub such as array("Class","student","term","score"...),remember that first element of the array is the "master" key and others is the "sub" keys from big to small, and all the keys union should point to a unique record,if Empty will use the row number(string) as the master key and no sub keys
'para3:isFirstRowTitle  -- (opti - default True) falg if the first row of the rang is the title row,if True will use the title as item key (title should be unique), if False,will use the colume number(string) as the item key

'I made this to make it easy to get table into a easy "find" easy "reference" scripting dictionary object for vba developers
'######################################################################################################################################################################################################
Public Function rg2hash(ByVal rg As Range, Optional ByVal keys As Variant = Empty, Optional ByVal isFirstRowTitle As Boolean = True) As Scripting.Dictionary
    Dim dicHeader As New Scripting.Dictionary
    Dim dicHeaderRev As New Scripting.Dictionary
    Dim csvrow As Range
    Dim csvfield As Range
    Dim dicResult As New Scripting.Dictionary
    Dim key As Variant
    Dim keyVals As Variant
    Dim lngIndex As Long
    Dim refDic As Scripting.Dictionary
    
    
    'first removeall
    dicResult.RemoveAll
    
    If isFirstRowTitle Then
        'if only title row exit
        If Not rg.Rows.Count > 1 Then
            Set rg2hash = Nothing
            Exit Function
        End If
        For Each csvfield In rg.Rows(1).Columns
            'place keys
            If Not dicHeader.Exists(csvfield.Value) And Not IsEmpty(csvfield.Value) Then
                dicHeader.Add CStr(csvfield.Value), csvfield.Column
                dicHeaderRev.Add CStr(csvfield.Column), csvfield.Value
            Else
                'key should not be duplicated
                Set rg2hash = Nothing
                Exit Function
            End If
        Next
    Else
        For Each csvfield In rg.Rows(1).Columns
            'if no title row, column number will be the item keys
            dicHeader.Add CStr(csvfield.Column), csvfield.Column
            dicHeaderRev.Add CStr(csvfield.Column), csvfield.Column
        Next
    End If
    
    lngIndex = 1
    'begin to scan the range and read recorders
    For Each csvrow In rg.Rows
        'if first row is title skip it
        If lngIndex = 1 And isFirstRowTitle Then
        
        Else
            'make the {master key -> sub key1 -> sub key2 -> ... -> new dictionary object} strcture
            keyVals = Array()
            If Not IsEmpty(keys) Then
                If UBound(keys) >= 0 Then
                    For Each key In keys
                        push_ref CStr(Cells(csvrow.Row, dicHeader.Item(CStr(key))).Value), keyVals
                    Next
                End If
            Else
                'if no master/sub keys set, row index (start from 1) will be the master key and no sub keys
                push_ref CStr(IIf(isFirstRowTitle, lngIndex - 1, lngIndex)), keyVals
            End If
            Set refDic = buildDic(dicResult, keyVals)
            
            'at the last sub key position write the detail(item) records
            For Each csvfield In csvrow.Columns
                refDic.Add CStr(dicHeaderRev.Item(CStr(csvfield.Column))), csvfield.Value
            Next
            
        End If
        lngIndex = lngIndex + 1
    Next
    Set rg2hash = dicResult
    Set refDic = Nothing
    Set dicHeader = Nothing
    Set dicHeaderRev = Nothing
End Function
'this is a function to make a master-sub key strctured dictionary object and refer to the last sub key ready to put the detial record
Public Function buildDic(ByRef dic As Scripting.Dictionary, ByVal keys As Variant) As Scripting.Dictionary
    Dim key As Variant
    If UBound(keys) > 0 Then
        If Not dic.Exists(keys(LBound(keys))) Then
            dic.Add CStr(keys(LBound(keys))), New Scripting.Dictionary
        End If
        Set buildDic = buildDic(dic.Item(CStr(keys(LBound(keys)))), shift_ref(keys))
    ElseIf UBound(keys) = 0 Then
        dic.Add CStr(keys(0)), New Scripting.Dictionary
        Set buildDic = dic.Item(CStr(keys(0)))
    End If
End Function
'this is a function to remove the first element of an array
Public Function shift_ref(ByRef arr As Variant) As Variant
    Dim u As Long
    u = UBound(arr)
    Dim l As Long
    If u < 1 Then
        shift_ref = Array()
        Exit Function
    End If
    Dim v() As Variant
    For l = LBound(arr) To u - 1
        ReDim Preserve v(l)
        v(l) = arr(l + 1)
    Next
    shift_ref = v
End Function

'this is a function to push an element into an array
Public Function push_ref(ByVal val As Variant, ByRef arr As Variant) As Integer
    If IsArray(arr) Then
        ReDim Preserve arr(UBound(arr) + 1)
    Else
        ReDim arr(0)
    End If
    arr(UBound(arr)) = val
    push_ref = UBound(arr)
End Function