EXCEL VBA でオリジナルカレンダーを作成

はじめに

今年のゴールデンウィークは大型連休となりましたが、天皇の即位の日の5月1日が休みとなったためです。

東京オリンピックの年（2020年）は、「海の日」は7月23日に、「体育の日（スポーツの日）」は7月24日に、「山の日」は8月10日になります。

そこで今回はEXCEL VBAを利用してオリジナルカレンダーを作成してみました。

子供やペット、自動車やアニメキャラなどで自分だけのカレンダーを作ってみてはいかがでしょうか？

EXCEL2013（64ビット）で動作確認

オリジナルカレンダーVer2はこちら

ダウンロード

オリジナルカレンダー

1 ファイル 1.89 MB

ダウンロード

今回のカレンダーは、A4縦サイズです。上段に好みの写真やイラストを表示できます。

1か月単位で出力できるので必要な分だけ印刷して利用できます。

ちょこっと解説

カレンダーシート

メインのシートです。このシートでカレンダーを生成し印刷できます。

画像シート

月ごとに画像ファイルを設定しておけます。

画像は、カレンダーEXCELと同じフォルダか下位のフォルダに格納して利用します。

画像形式は、イメージコントロールで読み込み可能なもので、BMP・JPG・GIFなどが指定可能です。残念ながらPNGは取り扱えません。

祝日シート

祝日シートは、内閣府のホームページからCSVをダウンロードしてきたものをそのまま貼り付けております。

特定の日を休みにしたい場合は、このシートに追加して利用できます。

休日シート

休日シートは、毎年繰り返しの休みを定義します。会社の正月休みなどがそれにあたります。

VBA

メイン処理

カレンダー（文字部分）をクリアします。
入力された年と月を取得し、カレンダーにセットします。
画像を取得しイメージコントロールにセットします。この時画像をズームするかしないかをセットします。
祝日・休日を配列で取得します。
カレンダーの日付部分をセットします。この時、祝日・休日配列と該当する日は文字を赤色にセットします。

''' カレンダーセット
Private Sub cmdSetCalender_Click()
On Error GoTo Err_Handler
    
    Dim nen As Integer
    Dim tuki As Integer
    Dim hiduke() As String
    Dim i As Integer
    Dim j As Integer
    Dim r As Integer    '' 行
    Dim c As Integer    '' 列
    Dim picFile As String
    Dim holiday() As String
    Dim userHoliday() As String
    
    ' カレンダークリア
    Call ClearCalender
    
    ' 年、月取得
    nen = Me.Cells(4, 9).Value
    tuki = Me.Cells(4, 10).Value
    
    ' 年、月セット
    Me.Cells(12, 1).Value = nen
    Me.Cells(12, 4).Value = tuki
    
    ' 画像
    picFile = GetPicture(tuki)
    If Me.chkZoom Then
        imgPic.PictureSizeMode = fmPictureSizeModeZoom
    Else
        imgPic.PictureSizeMode = fmPictureSizeModeClip
    End If
    imgPic.Picture = LoadPicture(picFile)
    
    ' 祝日取得
    holiday = GetHoliday(nen, tuki)
    ' 休日取得
    userHoliday = GetUserHoliday(tuki)
    
    ' 日セット
    '' 日付配列セット
    hiduke = SetDate(nen, tuki)
    r = 0
    c = 0
    For i = 15 To 20
        For j = 1 To 7
            Me.Cells(i, j).Value = hiduke(r, c)
            If hiduke(r, c) <> "" Then
                If holiday(CInt(hiduke(r, c))) <> "" Then
                    Me.Cells(i, j).Font.Color = RGB(255, 0, 0)
                End If
                If userHoliday(CInt(hiduke(r, c))) <> "" Then
                    Me.Cells(i, j).Font.Color = RGB(255, 0, 0)
                End If
            End If
            c = c + 1
        Next j
        r = r + 1
        c = 0
    Next i
    Exit Sub
    
Err_Handler:
    MsgBox Err.Description, vbExclamation

End Sub

''' カレンダーセット

Private Sub cmdSetCalender_Click()

On Error GoTo Err_Handler

Dim nen As Integer

Dim tuki As Integer

Dim hiduke() As String

Dim i As Integer

Dim j As Integer

Dim r As Integer '' 行

Dim c As Integer '' 列

Dim picFile As String

Dim holiday() As String

Dim userHoliday() As String

' カレンダークリア

Call ClearCalender

' 年、月取得

nen = Me.Cells(4, 9).Value

tuki = Me.Cells(4, 10).Value

' 年、月セット

Me.Cells(12, 1).Value = nen

Me.Cells(12, 4).Value = tuki

' 画像

picFile = GetPicture(tuki)

If Me.chkZoom Then

imgPic.PictureSizeMode = fmPictureSizeModeZoom

Else

imgPic.PictureSizeMode = fmPictureSizeModeClip

End If

imgPic.Picture = LoadPicture(picFile)

' 祝日取得

holiday = GetHoliday(nen, tuki)

' 休日取得

userHoliday = GetUserHoliday(tuki)

' 日セット

'' 日付配列セット

hiduke = SetDate(nen, tuki)

r = 0

c = 0

For i = 15 To 20

For j = 1 To 7

Me.Cells(i, j).Value = hiduke(r, c)

If hiduke(r, c) <> "" Then

If holiday(CInt(hiduke(r, c))) <> "" Then

Me.Cells(i, j).Font.Color = RGB(255, 0, 0)

End If

If userHoliday(CInt(hiduke(r, c))) <> "" Then

Me.Cells(i, j).Font.Color = RGB(255, 0, 0)

End If

c = c + 1

Next j

r = r + 1

c = 0

Next i

Exit Sub

Err_Handler:

MsgBox Err.Description, vbExclamation

End Sub

カレンダークリア処理

対象のセルをクリアします。この時、文字色を黒色にセットし、左端の日曜日は赤色に右端の土曜日は青色にします。

''' カレンダークリア
Private Sub ClearCalender()
On Error GoTo Err_Handler
    
    Dim i As Integer
    Dim j As Integer
    Dim lngColor As Long

    ' 年
    Me.Cells(12, 1).Value = ""
    ' 月
    Me.Cells(12, 4).Value = ""
    
    ' 画像
    imgPic.Picture = Nothing
    
    ' 日
    For i = 15 To 20
        For j = 1 To 7
            Me.Cells(i, j).Value = ""
            
            Me.Cells(i, j).Font.Color = RGB(0, 0, 0)
            If j = 1 Then Me.Cells(i, j).Font.Color = RGB(255, 0, 0)
            If j = 7 Then Me.Cells(i, j).Font.Color = RGB(0, 112, 192)
            
            Me.Cells(i, j).Font.TintAndShade = 0
        Next j
    Next i
    Exit Sub
    
Err_Handler:
    MsgBox Err.Description, vbExclamation

End Sub

''' カレンダークリア

Private Sub ClearCalender()

On Error GoTo Err_Handler

Dim i As Integer

Dim j As Integer

Dim lngColor As Long

' 年

Me.Cells(12, 1).Value = ""

' 月

Me.Cells(12, 4).Value = ""

' 画像

imgPic.Picture = Nothing

' 日

For i = 15 To 20

For j = 1 To 7

Me.Cells(i, j).Value = ""

Me.Cells(i, j).Font.Color = RGB(0, 0, 0)

If j = 1 Then Me.Cells(i, j).Font.Color = RGB(255, 0, 0)

If j = 7 Then Me.Cells(i, j).Font.Color = RGB(0, 112, 192)

Me.Cells(i, j).Font.TintAndShade = 0

Next j

Next i

Exit Sub

Err_Handler:

MsgBox Err.Description, vbExclamation

End Sub

日付配列セット処理

入力された年月の1日の曜日を取得します。
月末の日付を取得します。開始日に1か月足して1日引きます。
2次元配列を用意し、第1週は取得した曜日にあわせてセットします。

''' 日付配列セット
Private Function SetDate(y As Integer, m As Integer)
On Error GoTo Err_Handler
    
    Dim d(5, 6) As String
    Dim startDate As Date
    Dim endD As Integer
    Dim youbi As Integer    ' 1:日曜日　～　7：土曜日
    Dim i As Integer
    Dim j As Integer
    Dim dd As Integer
    
    ' 日付配列初期化
    For i = 0 To 5
        For j = 0 To 6
            d(i, j) = ""
        Next j
    Next i
    
    ' 開始曜日取得
    startDate = CDate(y & "/" & m & "/1")
    youbi = Weekday(startDate)
    
    ' 月末日付取得
    endD = CInt(Format(DateAdd("d", -1, DateAdd("m", 1, startDate)), "d"))
    
    dd = 1
    For i = 0 To 5
        If dd > endD Then Exit For
        For j = 0 To 6
            If i = 0 And j < youbi - 1 Then
            Else
                If dd > endD Then Exit For
                d(i, j) = Trim(CStr(dd))
                dd = dd + 1
            End If
        Next j
    Next i
    
    SetDate = d
    Exit Function
    
Err_Handler:
    MsgBox Err.Description, vbExclamation

End Function

''' 日付配列セット

Private Function SetDate(y As Integer, m As Integer)

On Error GoTo Err_Handler

Dim d(5, 6) As String

Dim startDate As Date

Dim endD As Integer

Dim youbi As Integer ' 1:日曜日　～　7：土曜日

Dim i As Integer

Dim j As Integer

Dim dd As Integer

' 日付配列初期化

For i = 0 To 5

For j = 0 To 6

d(i, j) = ""

Next j

Next i

' 開始曜日取得

startDate = CDate(y & "/" & m & "/1")

youbi = Weekday(startDate)

' 月末日付取得

endD = CInt(Format(DateAdd("d", -1, DateAdd("m", 1, startDate)), "d"))

dd = 1

For i = 0 To 5

If dd > endD Then Exit For

For j = 0 To 6

If i = 0 And j < youbi - 1 Then

Else

If dd > endD Then Exit For

d(i, j) = Trim(CStr(dd))

dd = dd + 1

End If

Next j

Next i

SetDate = d

Exit Function

Err_Handler:

MsgBox Err.Description, vbExclamation

End Function

画像ファイル名取得処理

画像シートの該当月をSELECT文で取得します。
取得したファイル名に、カレンダー.xlsmのフォルダパスを結合させます。

''' 画像ファイル名取得
Private Function GetPicture(m As Integer)
On Error GoTo Err_Handler
    
    Dim fname As String
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim xl_file As String
    Dim sql As String
    Dim curRow As Integer
    
    'ツールメニューの参照設定'
    ' Microsoft ActiveX Data Objects 2.8 Library'
    'チェック'
    xl_file = ThisWorkbook.FullName '他のブックを指定しても良い'
 
    Set cn = New ADODB.Connection
    cn.Provider = "MSDASQL"
    #If Win64 Then
        ' 64bit
        cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
    #Else
        ' 32bit
        cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
    #End If
    cn.Open
    
    Set rs = New ADODB.Recordset
    
    sql = "SELECT 画像ファイル名 FROM [画像$]" _
        & "  WHERE" _
        & "  月 = " & m
    rs.Open sql, cn, adOpenStatic
    
    fname = ThisWorkbook.Path & "\" & rs!画像ファイル名
    
    rs.Close
    cn.Close
    Set rs = Nothing
    Set cn = Nothing
    
    GetPicture = fname
    Exit Function
    
Err_Handler:
    MsgBox "画像取得 : " & Err.Description, vbExclamation
    On Error Resume Next
    rs.Close
    cn.Close
    Set rs = Nothing
    Set cn = Nothing

End Function

''' 画像ファイル名取得

Private Function GetPicture(m As Integer)

On Error GoTo Err_Handler

Dim fname As String

Dim cn As ADODB.Connection

Dim rs As ADODB.Recordset

Dim xl_file As String

Dim sql As String

Dim curRow As Integer

'ツールメニューの参照設定'

' Microsoft ActiveX Data Objects 2.8 Library'

'チェック'

xl_file = ThisWorkbook.FullName '他のブックを指定しても良い'

Set cn = New ADODB.Connection

cn.Provider = "MSDASQL"

#If Win64 Then

' 64bit

cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"

#Else

' 32bit

cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"

#End If

cn.Open

Set rs = New ADODB.Recordset

sql = "SELECT 画像ファイル名 FROM [画像$]" _

& " WHERE" _

& " 月 = " & m

rs.Open sql, cn, adOpenStatic

fname = ThisWorkbook.Path & "\" & rs!画像ファイル名

rs.Close

cn.Close

Set rs = Nothing

Set cn = Nothing

GetPicture = fname

Exit Function

Err_Handler:

MsgBox "画像取得 : " & Err.Description, vbExclamation

On Error Resume Next

rs.Close

cn.Close

Set rs = Nothing

Set cn = Nothing

End Function

祝日取得処理

祝日シートの該当月をSELECT文で取得します。
取得した休みの日付を添え字として配列に祝日名をセットします。

''' 祝日取得
Private Function GetHoliday(y As Integer, m As Integer)
On Error GoTo Err_Handler
    
    Dim i As Integer
    Dim d(31) As String
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim xl_file As String
    Dim sql As String
    Dim curRow As Integer
    
    Dim sYMD As Date
    Dim eYMD As Date
    
    'ツールメニューの参照設定'
    ' Microsoft ActiveX Data Objects 2.8 Library'
    'チェック'
    xl_file = ThisWorkbook.FullName '他のブックを指定しても良い'
 
    Set cn = New ADODB.Connection
    cn.Provider = "MSDASQL"
    #If Win64 Then
        ' 64bit
        cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
    #Else
        ' 32bit
        cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
    #End If
    cn.Open
    
    Set rs = New ADODB.Recordset
    
    sYMD = CDate(y & "/" & m & "/1")
    eYMD = DateAdd("d", -1, DateAdd("m", 1, sYMD))
    
    sql = "SELECT 年月日, 祝日名 FROM [祝日$]" _
        & "  WHERE" _
        & "  年月日 >= #" & sYMD & "# AND 年月日 <= #" & eYMD & "#"
    rs.Open sql, cn, adOpenStatic
    
    ' 祝日配列初期化
    For i = 1 To 31
        d(i) = ""
    Next i
    Do While Not rs.EOF
        d(Format(rs!年月日, "d")) = rs!祝日名
        rs.MoveNext
    Loop
    
    rs.Close
    cn.Close
    Set rs = Nothing
    Set cn = Nothing
    
    GetHoliday = d
    Exit Function
    
Err_Handler:
    MsgBox "祝日取得 : " & Err.Description, vbExclamation
    On Error Resume Next
    rs.Close
    cn.Close
    Set rs = Nothing
    Set cn = Nothing

End Function

''' 祝日取得

Private Function GetHoliday(y As Integer, m As Integer)

On Error GoTo Err_Handler

Dim i As Integer

Dim d(31) As String

Dim cn As ADODB.Connection

Dim rs As ADODB.Recordset

Dim xl_file As String

Dim sql As String

Dim curRow As Integer

Dim sYMD As Date

Dim eYMD As Date

'ツールメニューの参照設定'

' Microsoft ActiveX Data Objects 2.8 Library'

'チェック'

xl_file = ThisWorkbook.FullName '他のブックを指定しても良い'

Set cn = New ADODB.Connection

cn.Provider = "MSDASQL"

#If Win64 Then

' 64bit

cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"

#Else

' 32bit

cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"

#End If

cn.Open

Set rs = New ADODB.Recordset

sYMD = CDate(y & "/" & m & "/1")

eYMD = DateAdd("d", -1, DateAdd("m", 1, sYMD))

sql = "SELECT 年月日, 祝日名 FROM [祝日$]" _

& " WHERE" _

& " 年月日 >= #" & sYMD & "# AND 年月日 <= #" & eYMD & "#"

rs.Open sql, cn, adOpenStatic

' 祝日配列初期化

For i = 1 To 31

d(i) = ""

Next i

Do While Not rs.EOF

d(Format(rs!年月日, "d")) = rs!祝日名

rs.MoveNext

Loop

rs.Close

cn.Close

Set rs = Nothing

Set cn = Nothing

GetHoliday = d

Exit Function

Err_Handler:

MsgBox "祝日取得 : " & Err.Description, vbExclamation

On Error Resume Next

rs.Close

cn.Close

Set rs = Nothing

Set cn = Nothing

End Function

休日取得処理

休日シートの該当月をSELECT文で取得します。
取得した休みの日付を添え字として配列に祝日名をセットします。

Private Function GetUserHoliday(m As Integer)
''' ユーザ休日取得
On Error GoTo Err_Handler
    
    Dim i As Integer
    Dim d(31) As String
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim xl_file As String
    Dim sql As String
    Dim curRow As Integer
    
    Dim sYMD As Date
    Dim eYMD As Date
    
    'ツールメニューの参照設定'
    ' Microsoft ActiveX Data Objects 2.8 Library'
    'チェック'
    xl_file = ThisWorkbook.FullName '他のブックを指定しても良い'
 
    Set cn = New ADODB.Connection
    cn.Provider = "MSDASQL"
    #If Win64 Then
        ' 64bit
        cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
    #Else
        ' 32bit
        cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
    #End If
    cn.Open
    
    Set rs = New ADODB.Recordset
    
    sql = "SELECT 日, 休日名 FROM [休日$]" _
        & "  WHERE" _
        & "  月 = " & m
    rs.Open sql, cn, adOpenStatic
    
    ' 祝日配列初期化
    For i = 1 To 31
        d(i) = ""
    Next i
    Do While Not rs.EOF
        d(rs!日) = rs!休日名
        rs.MoveNext
    Loop
    
    rs.Close
    cn.Close
    Set rs = Nothing
    Set cn = Nothing
    
    GetUserHoliday = d
    Exit Function
    
Err_Handler:
    MsgBox "休日取得 : " & Err.Description, vbExclamation
    On Error Resume Next
    rs.Close
    cn.Close
    Set rs = Nothing
    Set cn = Nothing

End Function

Private Function GetUserHoliday(m As Integer)

''' ユーザ休日取得

On Error GoTo Err_Handler

Dim i As Integer

Dim d(31) As String

Dim cn As ADODB.Connection

Dim rs As ADODB.Recordset

Dim xl_file As String

Dim sql As String

Dim curRow As Integer

Dim sYMD As Date

Dim eYMD As Date

'ツールメニューの参照設定'

' Microsoft ActiveX Data Objects 2.8 Library'

'チェック'

xl_file = ThisWorkbook.FullName '他のブックを指定しても良い'

Set cn = New ADODB.Connection

cn.Provider = "MSDASQL"

#If Win64 Then

' 64bit

cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"

#Else

' 32bit

cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"

#End If

cn.Open

Set rs = New ADODB.Recordset

sql = "SELECT 日, 休日名 FROM [休日$]" _

& " WHERE" _

& " 月 = " & m

rs.Open sql, cn, adOpenStatic

' 祝日配列初期化

For i = 1 To 31

d(i) = ""

Next i

Do While Not rs.EOF

d(rs!日) = rs!休日名

rs.MoveNext

Loop

rs.Close

cn.Close

Set rs = Nothing

Set cn = Nothing

GetUserHoliday = d

Exit Function

Err_Handler:

MsgBox "休日取得 : " & Err.Description, vbExclamation

On Error Resume Next

rs.Close

cn.Close

Set rs = Nothing

Set cn = Nothing

End Function

終わりに

画像ファイル名の取得、祝日・休日の取得処理でSQLを利用していますが、SELECT文を渡すとレコードセットが返されるように共通化できますね。。。

画像シートはわざわざSELECTしなくても対応できますが、今後の拡張（複数の画像セットをあらかじめ用意しておくなど）を考えるとこのままでも良いのかなと。