作成した年月週の表ラベルに実際の値を充て込んでみる ②

昨日は、作成した年月週の表ラベルの値を充て込むために、元の表を扱いやすいよう編集してみた。
infoment.hatenablog.com

今日は更に、既存の値を転記するための辞書を作成することに挑戦する。

昨日、ラベルの文字を配列内で編集したのは、ラベルの文字を辞書（連想配列）のキーとするため。
key　：yyyymmww　※wwは今回、週の意。第１週であれば01。
item ：縦の値（配列）

図で見ると、こんな感じだ。

これは結構な面倒くささだと思っていたが、意外にこれが役に立った。
infoment.hatenablog.com

そこでまず、昨日の配列を取得する関数を、辞書を作る関数に修正する。

Function GetTableDict(table_range As Range) As Dictionary
    Dim seq As Variant
        seq = table_range
    
    ' 最初の三行について、値を全て数字のみにする。
    Dim r As Long
    Dim c As Long
    Dim str As String
        For r = 1 To 3
            For c = 2 To UBound(seq, 2)
                str = seq(r, c)
                If str <> vbNullString Then
                    seq(r, c) = ExtractNumbers(str)
                End If
            Next
        Next
        
    ' 三行目の値を基準に、空欄を埋めていく。
        For c = 3 To UBound(seq, 2)
            
            ' 一つ上のセルが空欄の場合、左斜め上の値を充てる。
            If seq(2, c) = vbNullString Then
                seq(2, c) = seq(2, c - 1)
            End If
            
            ' 二つ上のセルが空欄の場合
            If seq(1, c) = vbNullString Then
                ' 今月が先月より小さい場合は、年を一つ加える。
                ' ※１２月も翌１月も表に無い場合を想定。
                If seq(2, c) < seq(2, c - 1) Then
                    seq(1, c) = seq(1, c - 1) + 1
                Else
                    seq(1, c) = seq(1, c - 1)
                End If
            End If
        Next
        
    ' 二列目から順に、辞書に登録する。
    Dim SQC As SeaquenceClass
    Set SQC = New SeaquenceClass
    Dim Dict As Dictionary
    Set Dict = New Dictionary
    Dim myKey As Long
        For c = 2 To UBound(seq, 2)
            myKey = seq(1, c) & Format(seq(2, c), "00") & Format(seq(3, c), "00")
            Dict(myKey) = SQC.ExtractArray2(seq, 4, , c, c)
        Next
        
        Set GetTableDict = Dict
End Function

取得した辞書の値を、既存の表に充て込んでみる。

Sub testoooooooooooo()
    Dim Dict As Dictionary
    Set Dict = GetTableDict(Range("B1").CurrentRegion)
    
    Dim rMax As Long
        rMax = Range("B1").CurrentRegion.Rows.Count
    
    Dim DObj As DateObjectClass
    Set DObj = New DateObjectClass
    Dim seq As Variant
        
        ' 週が連続する配列を取得。
        seq = DObj.配列_年月週("2019/3/1", "2019/4/27")
        
        ' データの分だけ配列を拡張。
    Dim SQC As SeaquenceClass
    Set SQC = New SeaquenceClass
        seq = SQC.ExtractArray2(seq, , rMax)
            
    Dim myKey As Long
    Dim c As Long
    Dim r As Long
        ' 各列の年月週が辞書に存在する場合、その値をセットする。
        For c = 1 To UBound(seq, 2)
            myKey = seq(1, c) & Format(seq(2, c), "00") & Format(seq(3, c), "00")
            If Dict.Exists(myKey) Then
                For r = 1 To UBound(Dict.Keys) - 1
                    seq(r + 3, c) = Dict(myKey)(r)
                Next
            End If
        Next
        

        Range("B1").Resize(UBound(seq, 1), UBound(seq, 2)) = seq
End Sub

結果が ↓ こちら。

何とか、目的の動作を実現することが出来た。
と、ここで時間切れ。明日に続きます。

参考まで。