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

昨日はお遊びで、日付を入力したセル（１つ）を起点にカレンダーを作成してみた。
infoment.hatenablog.com
最初はお遊びで作成してみたが、意外と使えそうな気がして、その割に使いにくいことに気が付いた。そこで本日は、その改良に挑戦する。

改めて昨日のマクロを見て思ったこと。
【欲しい機能】（＝意外と使えそうなところ）

• 複数月のカレンダーを作れたら便利かも。

【使いにくい点】（＝改良すべきところ）

• カレンダーの行列が合わせにくいところ。

３月の隣に４月のカレンダーを作成する時、起点となる日をいつにして、それをどこに置けば良いかが分かりにくいのだ。

そこでまず、昨日のマクロを「MakeSingleCalendar」とする。
ついでに、昨日間違えていたカレンダーの綴りをコッソリ直しておく。
※中身は、昨日のものから微調整しています。

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
        dr = WorksheetFunction.WeekNum(TargetDate) - _
             WorksheetFunction.WeekNum(TargetDate - Day(TargetDate)) _
             + 1
    ' 選択セルの日付が何曜日かを求め、左方向のオフセット量を求める。
    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(, 3).Merge
        .HorizontalAlignment = xlLeft
    End With
    
End Sub

次に、指定月数分だけカレンダーを作成する。

Sub MakeCalendar(target_range As Range, carendar_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)
        
            ' 列数のオフセット量は、「yyyy年mm月」が３つのセルを
            ' 結合していることを加味している。
            Set target_range = YearMonthRange.Offset(3, 5 + dc)
                target_range.Value = NextMonth
            Call MakeSingleCalendar(target_range)
        Next
    End If
End Sub

早速テストしてみよう。

Sub test()
    Call MakeCalendar(Selection, 3)
End Sub

何とかうまくいったようだ。
しかし現時点では、大きな問題が一つ残っている。それは、際限なく右方向に追加されてしまうという問題だ。どこか適当なところで改行させたい。

ということで、今日は時間切れ。明日に続きます。

参考まで。