pandazx's blog

Hadoop, データ分析など雑多な技術ブログ

VBAで多次元配列を多次元辞書(連想配列)に変換

入力データが多次元配列でコメントと日付が入ったデータとする。

これを変換して、辞書のデータ構造が年→月→日→辞書(リスト風)→辞書というデータに変換する。

辞書(リスト風)はキーを0,1,2,3というようにして辞書を登録することを意味する。

VBAの設定として、辞書(Scripting.Dictionary)を使用可能にするため、 Visual Basic Editor画面からツール→参照設定でMicrosoft Scripting Runtimeにチェックをつける。

VBAのコードは以下のようになる。動作確認していないが、概ね以下のイメージ。

Function convertList2Dict(dataList) As Scripting.Dictionary
    Dim yearMonthDayDataDict As New Scripting.Dictionary
    Dim dataDict As New Scripting.Dictionary
    
    Dim idx As Variant
    For idx = LBound(dataList) To UBound(dataList)
        ' 日付を取得し、年月日を抽出
        Dim dateStr As String: dateStr = dataList(idx, 1)
        On Error GoTo Errorhandler
        Dim dateObj As Date: dateObj = dateStr
        Dim yearNum As Integer: yearNumAs = year(dateObj)
        Dim monthNum As Integer: monthNum = month(dateObj)
        Dim dayNum As Integer: dayNum = day(dateObj)
        
        ' 辞書の生成と値の設定
        Set dataDict = New Scripting.Dictionary
        dataDict .Add "comment", dataList(idx, 0)
        dataDict .Add "date", dataList(idx, 1)
        
        ' 該当年の辞書を取得。未登録なら作成
        If Not yearMonthDayDataDict.exists(yearNum) Then
            yearMonthDayDataDict.Add intersectionName, New Scripting.Dictionary
        End If
        ' 該当年、月の辞書を取得。未登録なら作成
        If Not yearMonthDayDataDict(yearNum).exists(monthNum) Then
            yearMonthDayDataDict(yearNum).Add monthNum, New Scripting.Dictionary
        End If
        ' 該当年、月、日の辞書を取得。未登録なら作成
        If Not yearMonthDayDataDict(yearNum)(monthNum).exists(dayNum) Then
            yearMonthDayDataDict(yearNum)(monthNum).Add dayNum, New Scripting.Dictionary
        End If
        ' 辞書を多次元辞書に登録
        Dim listIdx As Integer: listIdx = yearMonthDayDataDict(yearNum)(monthNum)(dayNum).Count
        yearMonthDayDataDict(yearNum)(monthNum)(dayNum).Add listIdx, dataDict
NextData:
    Next idx
    On Error GoTo 0
    Set convertList2Dict = yearMonthDayDataDict
    Exit Function
Errorhandler:
    ' エラーが発生すると、ここに飛ぶ
    ' 不正な日時はスキップ
    Resume NextData
End Function