【Excel VBA】４月始まりの年間カレンダーを自動作成

職場で掃除のチェック表として年間カレンダーを作っているのですが、年によって曜日がずれるため毎年作り直しです。

年に１回の作業ですがめんどくさいのでVBAで自動化です。ついでに月間カレンダーも作ってしまいます。

プログラムの内容
プログラミング
1. VBA
  1. 閏年の計算方法

プログラムの内容

https://www.iehohs.com/files/excel-auto-calendar.xlsm

こちらがサンプルのデータです。

縦A3で印刷できるサイズの年間カレンダーです。

年度ごとの作成を想定し４月始まりです。

カレンダーの各日付にはチェック欄を設けています。

月間カレンダーも各シートに作成します。

年間シートの実行ボタンからマクロ実行。

入力ボックスが出てくるので何年度のものを作成するか西暦４桁を入力するだけで作成されます。

プログラミング

VBA

Sub カレンダー作成()
    Dim thisYear As Variant
    Dim nextYear As Variant
    Dim firstDay As Integer
    Dim days As Integer
    Dim row As Integer
    Dim col As Integer
    Dim febFlg As Boolean
  
    '年度のカレンダーを作成するか入力
    thisYear = Application.InputBox("西暦を半角4桁の数字で入力してください。")
    
    'キャンセル時の処理
    If thisYear = False Then
        Exit Sub
    End If
    
    '4桁でない場合の処理
    If Len(thisYear) <> 4 Then
        MsgBox ("西暦は4桁で入力してください。" _
            & vbCrLf & "作業を中止します。")
        Exit Sub
    End If
     
    '次年度分の変数を用意
    nextYear = thisYear + 1
    
    '年間カレンダーの中身をリセットする
    For i = 3 To 48 Step 15
       Range(Cells(i, 1), Cells(i + 11, 23)).ClearContents
    Next
    
    '月間カレンダー各シートの中身をリセットする
    For i = 2 To 13
         Sheets(i).Range("A3:G14").ClearContents
    Next
    
    '年を入力
    Range("A1").Value = thisYear & "年"
    Range("A46").Value = nextYear & "年"
    
    '4月1日の曜日を取得、最初に入力する列を決定
    firstDay = Weekday(thisYear + "/04/01")
    col = firstDay
    
    '年間カレンダーを作成
    For i = 1 To 46 Step 15
        For j = 7 To 23 Step 8
            row = i + 2
            '各月の日数を算出
            Select Case Cells(i, j).Value
                Case "4月", "6月", "9月", "11月"
                    days = 30
                Case "2月"
                    febFlg = False
                    '2月の場合は閏年を判定
                    If nextYear Mod 400 <> 0 Then
                        If nextYear Mod 100 = 0 Then
                             days = 28
                        ElseIf nextYear Mod 4 = 0 Then
                            days = 29
                            febFlg = True
                        Else
                            days = 28
                        End If
                    Else
                        days = 29
                        febFlg = True
                    End If
                Case Else
                    days = 31
            End Select
            '１ヶ月分の日付を入力
            For k = 1 To days
                Cells(row, col).Value = k
                If col = j Then
                    row = row + 2
                    col = j - 6
                Else
                     col = col + 1
                End If
                If k = days Then
                    If j = 23 Then
                        col = col - 16
                    Else
                        col = col + 8
                    End If
                 End If
             Next k
        Next j
    Next i

    '月間カレンダーを作成
    col = firstDay
    For i = 2 To 13
        With Sheets(i)
            '年を入力
            If i >= 11 Then
                .Range("F1").Value = nextYear & "年"
            Else
                .Range("F1").Value = thisYear & "年"
            End If
            
            '各月の日数を算出
            Select Case i
                Case 2, 4, 7, 9
                    days = 30
                Case 12
                    If febFlg = True Then
                        days = 29
                    Else
                        days = 28
                    End If
                Case Else
                    days = 31
            End Select
            
            row = 3
            '各シートに1ヶ月分の日付を入力
            For j = 1 To days
                .Cells(row, col).Value = j
                If col = 7 Then
                    row = row + 2
                    col = 1
                Else
                    col = col + 1
                End If
                If j = days Then
                    row = 3
                End If
            Next j
        End With
    Next i
End Sub