入力した日付を起点に複数月のカレンダーを作成する、の続き。

昨日は、日付を入力したセル（１つ）を起点に、指定ヵ月後までのカレンダーを作成してみた。
infoment.hatenablog.com
しかし昨日の時点では、「折り返す」ことをしていなかったため、横長のカレンダーになってしまう。

そこで今回は、指定した月数でカレンダーを折り返すことに挑戦する。

（ＣＡＮＶＡで、「折り返す」で検索したら出てきた画像）。

といっても今回も、理屈としては難しくない。プログラミングというよりもむしろ、純然たる算数に近い感じか。

今回は、このように考えた。
例）１２ヵ月のカレンダーを、４ヵ月×３ヵ月で配置する場合。
まず横並びで、３ヵ月後まで配置するということは、４ヵ月目は１ヵ月目の真下に配置する必要がある。４ヵ月目であることを判別するには、

• １ヵ月目 ÷ ３ヵ月 の余り ⇒ １
• ２ヵ月目 ÷ ３ヵ月 の余り ⇒ ２
• ３ヵ月目 ÷ ３ヵ月 の余り ⇒ ０
• ４ヵ月目 ÷ ３ヵ月 の余り ⇒ １

というように、「割り算の余りが１のとき」で求めることが出来る。従ってｎヶ月周期で配置する場合は、以下のように考える。

余りが１のとき ⇒ ｎ－１カ月左に戻って１つ下に作成する。
それ以外のとき ⇒ 右隣に作成する。

以上を踏まえたコードがこちら。今回も微調整を加えているので、全文を掲載する。

Sub MakeSingleCalendar(target_range As Range)
    ' 選択範囲判定。
    ' 複数セルが選択されている場合、処理を終了する。
    If target_range.Count > 1 Then
        Exit Sub
    ' 入力値が日付でない場合、処理を終了する。
    ElseIf IsDate(target_range) = False Then
        Exit Sub
    Else
        ' 選択セルに入力されている日付を取得する。
        Dim TargetDate As Date
            TargetDate = target_range.Value
    End If
    
    ' 選択セルを基準に、カレンダーの開始セルを取得する。
    Dim StartRange As Range
    ' 選択セルの日付が当月第何週かを求め、上方向のオフセット量を求める。
    Dim dr As Long
        If Day(TargetDate) = 1 Then
            dr = 1
        Else
            dr = WorksheetFunction.WeekNum(TargetDate) - _
                 WorksheetFunction.WeekNum(TargetDate - Day(TargetDate)) _
                 + 1
        End If
        
    ' 選択セルの日付が何曜日かを求め、左方向のオフセット量を求める。
    Dim dc As Long
        dc = WorksheetFunction.Weekday(TargetDate) - 1

    Set StartRange = target_range.Offset(-dr, -dc)
        StartRange.Value = TargetDate - dc - 7 * dr
    
    ' カレンダーの範囲を、７行×７列とする。
    ' 一行目は、曜日ラベルに使用する。
    Dim CalendarRange As Range
    Set CalendarRange = StartRange.Resize(7, 7)
    
    With CalendarRange
        ' 計算式で日付を入力。
        .Cells(2, 1).Resize(6) = "=R[-1]C+7"
        .Columns("B:G") = "=RC[-1]+1"
        ' 一行目を、書式設定で曜日に変更。
        .Rows(1).NumberFormatLocal = "aaa"
        .HorizontalAlignment = xlCenter
        
        ' 以降、条件付き書式で色付けする。
        .FormatConditions.Delete
        ' 当月でないセルは灰色に塗りつぶす。
        With .Rows("2:7")
            .NumberFormatLocal = "d"
            .FormatConditions.Add Type:=xlExpression, _
                                  Formula1:="=MONTH(" & .Range("A1").Address(0, 0) & ")<>" & _
                                            "MONTH(" & .Range("A1").Offset(-3).Address(True, True) & ")"
            With .FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.14996795556505
            End With
            .FormatConditions(1).StopIfTrue = False
        End With

        ' 日曜日は、文字色を赤にする。
        .FormatConditions.Add Type:=xlExpression, _
                              Formula1:="=WEEKDAY(" & StartRange.Address(0, 0) & ")=1"
        .FormatConditions(2).Font.Color = -16777024
        
        ' 土曜日は、文字色を碧にする。
        .FormatConditions.Add Type:=xlExpression, _
                              Formula1:="=WEEKDAY(" & StartRange.Address(0, 0) & ")=7"
        .FormatConditions(3).Font.ThemeColor = xlThemeColorAccent1
    End With
    
    ' yyyy年mm月を追記。
    With StartRange.Offset(-2)
        .Value = Format(TargetDate, "yyyy年mm月")
        .Resize(, 4).Merge
        .HorizontalAlignment = xlLeft
    End With
    
End Sub

Sub MakeCalendar(target_range As Range, carendar_count As Long, column_count As Long)
    Call MakeSingleCalendar(target_range)
    Dim i As Long
    If carendar_count >= 2 Then
        For i = 2 To carendar_count
            ' 翌月１日を求める。
            Dim YearMonthRange As Range
            Set YearMonthRange = target_range.CurrentRegion.Cells(-1, 1)
            Dim NextMonth As Date
                NextMonth = WorksheetFunction.EDate(YearMonthRange, 1)
            
            ' 翌月１日の、カレンダー左端からの「ずれ」量を求める。
            Dim dc As Long
                dc = WorksheetFunction.Weekday(NextMonth)
            
            ' 翌月の年月表示セルを求める
            Dim NextYearMonthRange As Range
            
            ' カレンダーの行列で、翌月の位置を決定する。
            ' 「改行」するか否かは、周期（column_count）の１番目か否かで判定する。
            ' １番目か否かは、割り算の余りで求めている。
            
            ' 列数のオフセット量は、「yyyy年mm月」が4つのセルを
            ' 結合していることを加味している。
            If i Mod column_count = 1 Then
                Set NextYearMonthRange = YearMonthRange.Offset(11, -8 * (column_count - 1) - 1)
            Else
                Set NextYearMonthRange = YearMonthRange.Offset(, 4)
            End If
        
            Set target_range = NextYearMonthRange.Offset(3, dc)
                target_range.Value = NextMonth
            Call MakeSingleCalendar(target_range)
        Next
    End If
End Sub

それでは、テストしてみよう。

Sub test()
    With Range("C5")
        .NumberFormatLocal = "d"
        .Value = "4/1"
    End With
    Call MakeCalendar(Range("C5"), 12, 3)
End Sub

上手くいったようだ。

次回、使い勝手を考慮して、もう少しだけ微修正します。

参考まで。