【EXCEL VBA】日付を縦軸にも横軸にも設定できるカレンダー作成マクロ（ひな形）

日付を縦軸にも横軸にも自由に設定できるExcel VBAのカレンダー作成マクロ（ひな形）です。

進捗管理表やスケジュール表作成において、プロジェクトの性質やレイアウトに合わせて日付の配置方向を切り替えたい場合に役立ちます。

この記事でできること

• 指定した開始日から終了日までのカレンダーを自動生成します。
• マクロの切り替えにより、日付を縦軸（行方向）または横軸（列方向）に配置できます。
• 年・月・日・曜日を自動的に判別してセルに書き込みます。

想定環境・前提条件

• Microsoft Excel 2010以降（VBA実行環境が有効であること）
• シート上の指定セル（B2に開始日、B3に終了日、B4に方向「左」または「下」）に入力があること前提としています。

VBAコード全文

Option Explicit

Const Row As Integer = 7
Const COLUMN As Integer = 5

Enum Cal
    y = 0 '年
    m = 1 '月
    d = 2 '日
    aaa = 3 '曜日
End Enum

Sub make()
    
    Dim d As Date
    Dim Limit As Date
    Dim tmp As Range
    Dim i As Integer
    Dim max As Integer
    
    d = CDate(Range("B2").Value)
    Limit = CDate(Range("B3").Value)
    max = Limit - d
    
    Call Init(d)
    For i = COLUMN + 2 To COLUMN + 2 + max
        Set tmp = Range(Cells(Row, i), Cells(Row, i))
        Call SetDays(tmp, d)
        d = d + 1
    Next i
    
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range(Cells(Row, COLUMN), Cells(Row, COLUMN)).Select
    
End Sub

Sub SetDays(ByVal r As Range, ByVal d As Date)
    
    '年
    If Year(r.Offset(Cal.d, -1).Value) <> Year(d) Then
        r.Value = d
    End If
    
    '月
    If Month(r.Offset(Cal.d, -1).Value) <> Month(d) Then
        r.Offset(Cal.m, 0).Value = d
    End If
    
    '日
    r.Offset(Cal.d, 0).Value = d
    
    
    '曜日
    r.Offset(Cal.aaa, 0).Value = d
    
End Sub

Sub Init(ByVal d As Date)
    
    Dim r As Range
    
    '行全体のフォーマット変更
    Call ClearFormat
    Call ClearFormat2
    Call SetFormat
    
    Set r = Range(Cells(Row, COLUMN), Cells(Row, COLUMN))

    r.Offset(Cal.y, 0).Value = "年"
    r.Offset(Cal.m, 0).Value = "月"
    r.Offset(Cal.d, 0).Value = "日"
    r.Offset(Cal.aaa, 0).Value = "曜日"
        
    '年
    r.Offset(Cal.y, 1).Value = d
    '月
    r.Offset(Cal.m, 1).Value = d
    '日
    r.Offset(Cal.d, 1).Value = d
    '曜日
    r.Offset(Cal.aaa, 1).Value = d
        
End Sub

Sub ClearFormat()
    Dim r As Range
    Dim area As String
    area = Row & ":" & Row + Cal.aaa
    Set r = Rows(area)
    r.ClearContents
    r.NumberFormatLocal = "G/標準"
End Sub

Sub SetFormat()
    Dim r As Range
    Dim area As String
    
    area = Row + Cal.y & ":" & Row + Cal.y
    Set r = Rows(area)
    r.NumberFormatLocal = "yy"
    
    area = Row + Cal.m & ":" & Row + Cal.m
    Set r = Rows(area)
    r.NumberFormatLocal = "mm"
    
    
    area = Row + Cal.d & ":" & Row + Cal.d
    Set r = Rows(area)
    r.NumberFormatLocal = "dd"
    
    area = Row + Cal.aaa & ":" & Row + Cal.aaa
    Set r = Rows(area)
    r.NumberFormatLocal = "aaa"

End Sub

Sub make2()
    
    Dim d As Date
    Dim Limit As Date
    Dim tmp As Range
    Dim i As Integer
    Dim max As Integer
    
    d = CDate(Range("B2").Value)
    Limit = CDate(Range("B3").Value)
    max = Limit - d
    
    Call Init2(d)
    For i = Row + 2 To Row + 2 + max
        Set tmp = Range(Cells(i, COLUMN), Cells(i, COLUMN))
        Call SetDays2(tmp, d)
        d = d + 1
    Next i
    
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range(Cells(Row, COLUMN), Cells(Row, COLUMN)).Select
    
End Sub

Sub Init2(ByVal d As Date)
    
    Dim r As Range
    
    '行全体のフォーマット変更
    Call ClearFormat
    Call ClearFormat2
    Call SetFormat2
    
    Set r = Range(Cells(Row, COLUMN), Cells(Row, COLUMN))

    r.Offset(0, Cal.y).Value = "年"
    r.Offset(0, Cal.m).Value = "月"
    r.Offset(0, Cal.d).Value = "日"
    r.Offset(0, Cal.aaa).Value = "曜日"
        
    '年
    r.Offset(1, Cal.y).Value = d
    '月
    r.Offset(1, Cal.m).Value = d
    '日
    r.Offset(1, Cal.d).Value = d
    '曜日
    r.Offset(1, Cal.aaa).Value = d
        
End Sub

Function ConvertToLetter(iCol As Integer) As String
   Dim iAlpha As Integer
   Dim iRemainder As Integer
   iAlpha = Int((iCol - 1) / 26)
   iRemainder = iCol - (iAlpha * 26)
   If iAlpha > 0 Then
      ConvertToLetter = Chr(iAlpha + 64)
   End If
   If iRemainder > 0 Then
      ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
   End If
End Function

Sub ClearFormat2()
    Dim r As Range
    Dim area As String
    area = ConvertToLetter(COLUMN + Cal.y) & ":" & ConvertToLetter(COLUMN + Cal.aaa)
    Set r = Columns(area)
    r.ClearContents
    r.NumberFormatLocal = "G/標準"
End Sub

Sub SetFormat2()
    Dim r As Range
    Dim area As String
    
    area = ConvertToLetter(COLUMN + Cal.y) & ":" & ConvertToLetter(COLUMN + Cal.y)
    Set r = Columns(area)
    r.NumberFormatLocal = "yy"
    
    area = ConvertToLetter(COLUMN + Cal.m) & ":" & ConvertToLetter(COLUMN + Cal.m)
    Set r = Columns(area)
    r.NumberFormatLocal = "mm"
    
    area = ConvertToLetter(COLUMN + Cal.d) & ":" & ConvertToLetter(COLUMN + Cal.d)
    Set r = Columns(area)
    r.NumberFormatLocal = "dd"
    
    area = ConvertToLetter(COLUMN + Cal.aaa) & ":" & ConvertToLetter(COLUMN + Cal.aaa)
    Set r = Columns(area)
    r.NumberFormatLocal = "aaa"

End Sub

Sub SetDays2(ByVal r As Range, ByVal d As Date)
    
    '年
    If Year(r.Offset(-1, Cal.d).Value) <> Year(d) Then
        r.Value = d
    End If
    
    '月
    If Month(r.Offset(-1, Cal.d).Value) <> Month(d) Then
        r.Offset(0, Cal.m).Value = d
    End If
    
    '日
    r.Offset(0, Cal.d).Value = d
    
    
    '曜日
    r.Offset(0, Cal.aaa).Value = d
    
End Sub

Private Sub CommandButton1_Click()
    Dim tmp As String
    tmp = Cells(4, 2)
    
    If tmp = "左" Then
        Call make
    ElseIf tmp = "下" Then
        Call make2
    ElseIf tmp = "クリア" Then
        Call ClearFormat
        Call ClearFormat2
    End If
    
End Sub