셀을 지정해 CurrentRegion로 범위 취득한 테이블을, 키+배열로 Dictionary에 부치 넣는다

    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim arr As Variant: arr = Sheets("Sheet2").Range("E6").CurrentRegion.Value
    Dim arrItem()
    Dim maxColNum_0 As Integer: maxColNum_0 = UBound(arr, 2) - 2
    Dim LP1 As Long, LP2 As Long

    ReDim arrItem(maxColNum_0)

    For LP1 = 2 To UBound(arr, 1)
        For LP2 = 0 To maxColNum_0
            arrItem(LP2) = arr(LP1, LP2 + 2)
        Next LP2
        dic.Add arr(LP1, 1), arrItem
    Next LP1


'----デバッグ部----
'配列の中身を全部見せ
  Dim i As Integer, j As Integer, str As String
  Dim maxRow As Integer:  maxRow = UBound(arr, 1)
  Dim maxColumn As Integer: maxColumn = UBound(arr, 2)

  For i = 1 To maxRow
    For j = 1 To maxColumn
        str = "arr(" & i & ", " & j & ")=" & arr(i, j)
        Debug.Print str
    Next
    Debug.Print
  Next

'Dicの中身を全部見せ
    Dim var As Variant
    For Each var In dic
        Debug.Print "キー:" & var
        For LP2 = 0 To maxColNum_0
            Debug.Print "dic(" & var & ")(" & LP2 & "):", dic(var)(LP2)
        Next LP2
    Next var
End Sub