VBA

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

メイン処理
  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しなくても対応できますが、今後の拡張（複数の画像セットをあらかじめ用意しておくなど）を考えるとこのままでも良いのかなと。

 

スポンサードリンク

スポンサードリンク

32ビット 64ビット A4横 A4縦 ADDRESS BASP21 camera COLUMN CSVダウンロード EXCEL出力 Hello World IF INDIRECT Kivy LEFT LEN LINE messagebox MID OpenCV POP3 ROW SQL TEXT Windows Windows10 WorksheetFunction エンドロール カレンダー システムの種類 スケジュール パスワード設定 ピンボケ メール一括配信 メール送信 万年カレンダー 住所 六曜 分割 条件付き書式 添付ファイル 画像 都道府県 集計 高速化

-VBA
-,

Copyright© あきらちんの技術メモ , 2024 All Rights Reserved Powered by STINGER.