サイトアイコン あきらちんの技術メモ

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

akiratin

はじめに

今年のゴールデンウィークは大型連休となりましたが、天皇の即位の日の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

メイン処理
  1. カレンダー（文字部分）をクリアします。
  2. 入力された年と月を取得し、カレンダーにセットします。
  3. 画像を取得しイメージコントロールにセットします。この時画像をズームするかしないかをセットします。
  4. 祝日・休日を配列で取得します。
  5. カレンダーの日付部分をセットします。この時、祝日・休日配列と該当する日は文字を赤色にセットします。
''' カレンダーセット
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

 

カレンダークリア処理
  1. 対象のセルをクリアします。この時、文字色を黒色にセットし、左端の日曜日は赤色に右端の土曜日は青色にします。
''' カレンダークリア
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日の曜日を取得します。
  2. 月末の日付を取得します。開始日に1か月足して1日引きます。
  3. 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

 

 画像ファイル名取得処理
  1. 画像シートの該当月をSELECT文で取得します。
  2. 取得したファイル名に、カレンダー.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
祝日取得処理
  1. 祝日シートの該当月をSELECT文で取得します。
  2. 取得した休みの日付を添え字として配列に祝日名をセットします。
''' 祝日取得
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

 

休日取得処理
  1. 休日シートの該当月をSELECT文で取得します。
  2. 取得した休みの日付を添え字として配列に祝日名をセットします。
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しなくても対応できますが、今後の拡張（複数の画像セットをあらかじめ用意しておくなど）を考えるとこのままでも良いのかなと。

 

モバイルバージョンを終了