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

「makecal.zip」をダウンロード

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

進捗管理やスケジュール管理で必須だけど、それを手で作成すると手間が多いので、、、

カレンダー作成マクロ

仕事内容によってカレンダー日付の軸が縦軸（ROW）が便利だったり、横軸（COLUMS）が便利だったりするので、そこは柔軟に対応させるようにした。

後は、休日は色をつけるとか、当日にフォーカスさせるとか、もう少し装飾して完成。

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

‘http://support.microsoft.com/kb/833402/ja
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