Excelでカレンダーを自動作成するVBAマクロ

Excelで西暦を入力するだけで4月始まりの年間＆月間カレンダーを作成するマクロです。

職場の掃除チェック用に年間のカレンダーを作っていたのですが、これがまためんどくさかったので作っちゃいました。

ついでに月間のカレンダーも各シートに作成してくれます。予定を書き込んで人に配布するなどに使えるかと（最新のExcelなら新規作成の画面で月間カレンダーのテンプレが選べるみたい）

Excelファイル
VBA
1. 閏年の計算方法

Excelファイル

excel-auto-calendar.xlsm

マクロを使用したブックのため、ネットから入手したファイル云々とかいろいろ警告が出ますが気にしないでマクロを有効にしてください。

年間のカレンダーを自動作成します。縦A3で印刷できるようにしています。カレンダーの各日付にはチェック欄を設けています。

さらに各シートに月間カレンダーを作成します。空欄はちょっとしたメモができると思います。

マクロは年間シートの実行ボタンから可能。入力ボックスが出てくるので何年度のものを作成するか西暦4桁を入力してOKを押すと自動作成します。

VBA

流れ的には西暦を入力したらその年の4月1日の曜日を取得し、どの列からスタートするかを決定、あとは順番に日付を入力していきます。

Sub autoCalendar()
    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
        MsgBox ("キャンセルが押されました。" _
            & vbCrLf & "作業を中止します。")
        Exit Sub
    End If
    
    If Not 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
            If Cells(i, j).Value = "4月" Or Cells(i, j).Value = "6月" Or Cells(i, j).Value = "9月" Or Cells(i, j).Value = "11月" Then
                days = 30
            ElseIf Cells(i, j).Value = "2月" Then
                febFlg = False
                '閏年を判定'
                If Not 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
            Else
                days = 31
            End If
            '１ヶ月分の日付を入力'
            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
        Next
    Next

    '月間カレンダーを作成'
    col = firstDay
    For i = 2 To 13
        If i >= 11 Then
              Sheets(i).Range("F1").Value = nextYear & "年"
        Else
              Sheets(i).Range("F1").Value = thisYear & "年"
        End If
        If i = 2 Or i = 4 Or i = 7 Or i = 9 Then
            days = 30
        ElseIf i = 12 Then
            If febFlg = True Then
                days = 29
            Else
                days = 28
            End If
        Else
             days = 31
        End If
        row = 3
        '各シートに1ヶ月分の日付を入力'
        For j = 1 To days
            Sheets(i).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
    Next
End Sub

※2020年2月1日追記　うまく動作しないことがわかったため修正しています。