入力した日付を起点にカレンダーを作成する

お遊びで、日付を入力したセル（１つ）を選択して実行すると、カレンダーになるマクロを作ってみた。思ったより、長々としたものになってしまった。

Option Explicit

Sub MakeCalender(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 CalenderRange As Range
    Set CalenderRange = StartRange.Resize(7, 7)
    
    With CalenderRange
        ' 計算式で日付を入力。
        .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(" & target_range.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 test()
    MakeCalender Selection
End Sub

おお、上手くいった。では、これをどこで使うかというと・・そこまでは、考えてませんでした。お遊びでしたので。

参考まで。