Excelのテーブルをオブジェクトの集合へ変換する関数

概要

Excelのテーブル（ListObject）の各行を見出しをKeyとするDictionaryに変換し、Collectionに格納して返す関数。

全行全列を取り込むため、データ数が多いと処理速度・メモリ使用量が悪化する可能性があります。

コード本体

''' <summary>
''' srcTableの各行を見出しをKeyとするDictionaryへ変換し
''' Collectionへ格納します｡
''' </summary>
''' <param name="srcTable">変換するテーブル。</param>
''' <returns>Scripting.Dictionaryを要素とするVBA.Collection</returns>
Function TableToDictionaries(ByVal srcTable As Excel.ListObject) As VBA.Collection
    
'テーブルからデータをメモリ上にロード
    
    '[Range].Value() はセル数が1個の時配列を返さないことへの対策
    Dim headers() As Variant
    With srcTable.HeaderRowRange
        If .Count = 1 Then
            ReDim headers(1 To 1, 1 To 1)
            headers(1, 1) = .Value()
        Else
            headers = .Value()
        End If
    End With 'srcTable.HeaderRowRange
    
    Dim tableBody() As Variant
    With srcTable.DataBodyRange
        If .Count = 1 Then
            ReDim tableBody(1 To 1, 1 To 1)
            tableBody(1, 1) = .Value()
        Else
            tableBody = .Value()
        End If
    End With 'srcTable.DataBodyRange
    
    
    Dim retCol As VBA.Collection
    Set retCol = New VBA.Collection
    
'オブジェクト化
    Dim r As Long, c As Long
    For r = LBound(tableBody, 1) To UBound(tableBody, 1)
        Dim dataDic As Object 'As Scripting.Dictionary
        Set dataDic = VBA.CreateObject("Scripting.Dictionary")
        
        For c = LBound(headers, 2) To UBound(headers, 2)
            Let dataDic.Item(headers(1, c)) = tableBody(r, c)
        Next c
        
        retCol.Add dataDic
    Next r
    
    Set TableToDictionaries = retCol
    
End Function

サンプル

Sub Sample()
    Dim ws As Excel.Worksheet
    Set ws = Excel.ActiveSheet
    
    Dim tblData As VBA.Collection
    Set tblData = TableToDictionaries(ws.ListObjects.Item(1))
    
'テーブルの中身をイミディエイトウィンドウに出力
    '見出し
    Debug.Print VBA.Join(tblData.Item(1).Keys(), vbTab)
    
    'データ部
    Dim dic As Object 'As Scripting.Dictionary
    For Each dic In tblData
        Debug.Print VBA.Join(dic.Items(), vbTab)
    Next dic
    
    Stop
    
End Sub