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

昨日は、作成した年月週の表ラベルを扱いやすい形に編集し、既存の値を転記してみた。
infoment.hatenablog.com
今日は更に、表の値が元の書式に戻すため、不要な値を消し込むことに挑戦する。

必要な情報は全て、昨日までに記入済み。従って今日は、さほど難しくない。むしろこのような形式にすることの是非を問われそうだが、仕様なのだからしょうがない（※ダジャレではありません）。

ということで、以下を行う。

1. 年月のうち、左隣と重複している箇所を削除する。
2. 年月週の行について、書式設定を行う。

１．については、↓ こんな感じだ。黄セルは左隣と値が同じなため、削除対象となる。

２．については、張り付けた後に書式設定を行う。↓ こんな感じだ。

こうなるよう、昨日のコードに追記した結果がこちら。

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
        
        ' 年月から、重複するものを削除する。
        For r = 1 To 2
            For c = UBound(seq, 2) To 2 Step -1
                If seq(r, c) = seq(r, c - 1) Then
                    seq(r, c) = vbNullString
                End If
            Next
        Next

        With Range("B1").Resize(UBound(seq, 1), UBound(seq, 2))
            .Value = seq
            ' 年の書式設定
            .Rows(1).NumberFormatLocal = "0000年"
            ' 月の書式設定
            .Rows(2).NumberFormatLocal = "0月"
            ' 週の書式設定
            .Rows(3).NumberFormatLocal = "第0週"
        End With
End Sub

実行した結果がこちら。

ここで、今日も時間切れ。
でも、明日には終われそうです。

参考まで。