エクセルでカレンダーを作成するマクロ | エクセルマクロ(VBA)実践蔵(じっせんぐら)
- エクセルマクロ(VBA)実践蔵 >
- 項目一覧 >
- エクセルでカレンダーを作成するマクロ
エクセルでカレンダーを作成するマクロ最終更新日：2023-06-13
生成できるカレンダーの見た目
エクセルにカレンダーを生成するマクロの使い方
セルB２に年を設定し、セルD2に月を設定します。
カレンダーの土曜日や日曜日・祝日、休日のカレンダー背景色やフォントカラーは、それぞれ、H2～H4セルの設定値を使用します。
国民の休日は、自動で設定され、「日曜日・祝日」のカラー設定で表示されます。追加で、誕生日や特別休暇、定休日等個別に設定したい日付を年間行事一覧(セルG8 ～)に設定することで、カレンダー作成時に読み込まれます。年間行事のH列に設定する休日識別は「休日」又は「平日」のどちらかを設定してください。色設定の「休日」は年間行事の「休日識別」に「休日」を設定した日に適応されます。
年間行事に設定される日付は重複していても構いません。改行して表示されます。
色の優先順位は、土曜日 < 日曜・祝 < 年間行事の休日 となります。
毎月決まった日にちの予定を設定できるように機能を追加しました。(2019/8/10)
毎月設定が〇の場合、日付列の月は無視され、各月の同じ日に予定が設定されます。
上の図では、例として、8/1 平日 朝礼 と設定し、毎月設定を〇とすると、すべての月の一日に朝礼が記入されます。毎月設定が〇の場合、土曜/日曜・祝日/休日で表示させるかさせないかを、土曜のとき(K列)/日曜・祝日のとき(L列)/休日のとき(M列)で詳細設定を可能にしました。
カレンダーのセルの幅や高さ、フォントサイズはすべて、テンプレートとして読み込んでいる「temp」シートに設定されているままのため、拡大・縮小等のサイズ変更はエクセルの編集ができる方なら可能です。
マクロの説明
カレンダーの作成ボタンを押された時の処理
シートオブジェクトに記載します。
Sub GetCal()
Call GetCalendar(Range("B2"), Range("D2"))
End Sub
今回はほとんどのコードを標準モジュールに記載しています。上記で呼び出しているGetCalendarを標準モジュールに記述していきます。
カレンダー作成のメイン処理
エクセルの表の構成やカレンダーに依存するコードになりますが、複数シートを扱うため、標準モジュールに記述していきます。
'カレンダーを生成するシートの個別情報
Public Function GetMyScheduleRng() As Range
Set GetMyScheduleRng = ThisWorkbook.Worksheets("実行").Range("G8")
End Function
Public Function GetColorSatDayRng() As Range
Set GetColorSatDayRng = ThisWorkbook.Worksheets("実行").Range("H2")
End Function
Public Function GetColorSunDayRng() As Range
Set GetColorSunDayRng = ThisWorkbook.Worksheets("実行").Range("H3")
End Function
Public Function GetColorPrivateHolidayRng() As Range
Set GetColorPrivateHolidayRng = ThisWorkbook.Worksheets("実行").Range("H4")
End Function
'カレンダーを作成する
Function GetCalendar(YearStr As String, MonthStr As String)
'年月の数値情報格納変数
Dim yearDigit As Long, monthDigit As Long
'1日の曜日を表す数値(WeekDay関数の戻り値)
Dim startWeek As Integer
'月末のDateオブジェクト型と日数
Dim lastDate As Date, lastDayDigit As Long
'新しく作成するシートオブジェクト
Dim newSheet As Worksheet
'ループカウンタ(日数カウンタ,行数カウンタ,列数カウンタ)
Dim cnt As Long, rowCnt As Long, colCnt As Long
'日にちの数値情報
Dim dayCnt As Long
'ループ内のDateオブジェクト(thisDate)と祝日名文字列
Dim thisDate As Date, Holiday As String
'列数offset(カレンダーがB列から使用しているためのoffset)
'thisRngはループ内で日付を入力するセル
Dim offset As Long, thisRng As Range
Dim typeStr As String, ScheduleStr As String
Dim chkScheduleRng As Range
Dim dispFlg As Boolean
Dim holidayflg As Boolean
yearDigit = 0
monthDigit = 0
offset = 1
If IsNumeric(YearStr) = True Then
'全角なら半角に
YearStr = StrConv(YearStr, vbNarrow)
yearDigit = Val(YearStr)
If IsNumeric(MonthStr) = True Then
'全角なら半角に
MonthStr = StrConv(MonthStr, vbNarrow)
monthDigit = Val(MonthStr)
End If
End If
'年の数値情報と月の数値情報が取得できていたら、処理を行う
If yearDigit <> 0 And monthDigit <> 0 Then
'新規シートを作成する関数呼び出し(tempシートを複製して、〇年〇月にリネーム)
Set newSheet = CopySheet_inBook("temp", YearStr & "年" & MonthStr & "月")
'複製したシートにカレンダー情報を設定していく
newSheet.Range("B1").Value = YearStr & "年" & MonthStr & "月"
'一日(ついたち)の曜日
startWeek = Weekday(yearDigit & "/" & monthDigit & "/" & 1)
'月末の日付を取得
lastDate = DateSerial(yearDigit, monthDigit + offset, 0)
lastDayDigit = Day(lastDate)
If startWeek + lastDayDigit - 1 < 36 Then '5行以内で収まる場合
'カレンダーの一行(セルとしては二行)を削除
newSheet.Rows("5:6").Delete
End If
'日付数値を入力する
rowCnt = 3
dayCnt = 1
For cnt = startWeek To lastDayDigit + startWeek - 1
colCnt = cnt Mod 7
If colCnt = 0 Then
colCnt = 7
End If
'日数を入力
Set thisRng = newSheet.Cells(rowCnt, colCnt + offset)
thisRng.Value = dayCnt
holidayflg = False
'土曜日の場合の色を設定
If colCnt = 7 Then
'土曜日のフォントカラーを設定
thisRng.Font.Color = GetColorSatDayRng.Font.Color
thisRng.Interior.Color = GetColorSatDayRng.Interior.Color
thisRng.Cells(2, 1).Font.Color = GetColorSatDayRng.Font.Color
thisRng.Cells(2, 1).Interior.Color = GetColorSatDayRng.Interior.Color
ElseIf colCnt = 1 Then
'日曜日
thisRng.Font.Color = GetColorSunDayRng.Font.Color
thisRng.Interior.Color = GetColorSunDayRng.Interior.Color
thisRng.Cells(2, 1).Font.Color = GetColorSunDayRng.Font.Color
thisRng.Cells(2, 1).Interior.Color = GetColorSunDayRng.Interior.Color
holidayflg = True
End If
thisDate = yearDigit & "/" & monthDigit & "/" & dayCnt
Holiday = 祝日判定(thisDate)
If Holiday <> "" Then
' If isNationalHoliday2(thisDate, Holiday) = True Then
'日曜日・祝日のフォントカラーを設定
thisRng.Font.Color = GetColorSunDayRng.Font.Color
thisRng.Interior.Color = GetColorSunDayRng.Interior.Color
thisRng.Cells(2, 1).Value = Holiday
thisRng.Cells(2, 1).Font.Color = GetColorSunDayRng.Font.Color
thisRng.Cells(2, 1).Interior.Color = GetColorSunDayRng.Interior.Color
holidayflg = True
End If
' 年間行事の探索
Set chkScheduleRng = Nothing
Do While IsPrivateSchedule(chkScheduleRng, thisDate, typeStr, ScheduleStr) = True
' 毎月設定の場合、既に日祝/土曜/休日で表示させるか判断する
If StrComp(chkScheduleRng.offset(0, 3).Text, "〇", vbTextCompare) = 0 Then
'土曜日と重なっている場合
If Weekday(thisDate) = vbSaturday Then
'年間行事表の土曜日が×なら表示しない、それ以外は表示する
If StrComp(chkScheduleRng.offset(0, 4).Text, "×", vbTextCompare) = 0 Then
dispFlg = False
Else
dispFlg = True
End If
'祝日の場合
ElseIf holidayflg = True Then
'年間行事表の祝日欄が×なら表示しない、それ以外は表示する
If StrComp(chkScheduleRng.offset(0, 5).Text, "×", vbTextCompare) = 0 Then
dispFlg = False
Else
dispFlg = True
End If
'休日の場合(カレンダーのセル色が休日カラーの場合)
'先に休日情報が設定されている日だった場合
ElseIf thisRng.Interior.Color = GetColorPrivateHolidayRng.Interior.Color Then
'年間行事表の休日欄が×なら表示しない、それ以外は表示する
If StrComp(chkScheduleRng.offset(0, 6).Text, "×", vbTextCompare) = 0 Then
dispFlg = False
Else
dispFlg = True
End If
'平日なら表示する
Else
dispFlg = True
End If
'毎月設定なしなら表示する
Else
dispFlg = True
End If
' -----------------------
' 表示する判定になった場合
' -----------------------
If dispFlg = True Then
'カレンダーで日付の下のセルが空なら予定をそのまま記述する
If thisRng.offset(1, 0).Value = "" Then
thisRng.offset(1, 0).Value = ScheduleStr
'予定が記入済みなら、文字列の連結で改行の後ろに予定を追加する
Else
thisRng.offset(1, 0).Value = thisRng.offset(1, 0).Value _
& vbCrLf & ScheduleStr
End If
'種別が休日なら
If typeStr = "休日" Then
'色を変える
thisRng.Font.Color = GetColorPrivateHolidayRng.Font.Color
thisRng.Interior.Color = GetColorPrivateHolidayRng.Interior.Color
thisRng.offset(1, 0).Font.Color = GetColorPrivateHolidayRng.Font.Color
thisRng.offset(1, 0).Interior.Color = GetColorPrivateHolidayRng.Interior.Color
End If
End If
Loop
'日付カウンタを更新
dayCnt = dayCnt + 1
'7の倍数で行数を移動させる
If cnt Mod 7 = 0 Then
rowCnt = rowCnt + 2
End If
Next cnt
End If
End Function
カレンダー作成のメイン処理の解説
一番上は、実行シートから受け取るセル情報を返す関数群です。
次にセルから受け取る年と月の数値情報が全角でも受け取れるように、チェック処理を入れています。
シートを複製してリネームする関数CopySheet_inBookは、下記シートを複製してリネームする関数に記述しています。
実行シートの年間行事表からデータを読み取る関数IsPrivateScheduleは、下記年間行事表から一致する情報を取得するマクロに記述しています。年間行事表の構成はこちら
カレンダーの入力すべき位置(行数や列数)の計算しながらループさせています。カレンダーの見た目
ループ内で、土曜日や日曜日、祝日の場合、背景色やフォント色の変更を行っています。
また、年間行事表で予定が入っていても、土曜や日曜祝日、休日の識別をつけた日に×がついている場合は、表示させないため、その条件確認を行っています。
あまり、見やすいコードではないですが、使いまわすようなコードでもないので、そのままにしています。なるべくコメントで補足しました。
年間行事表から一致する情報を取得するマクロ
ひきつづき、標準モジュールに記述していきます。
'実行シートの年間行事情報からChkDateの予定を取得する
Function IsPrivateSchedule(ByRef getDateRng As Range, ByVal ChkDate As Date, ByRef ScheduleType As String, ByRef ScheduleStr As String) As Boolean
Dim getDate As Date
Dim AllMonthStr As String
Dim allMonthChk As Integer
'初期値でスケジュールなしを設定
IsPrivateSchedule = False
If getDateRng Is Nothing Then
'個別年間行事の開始行を設定
Set getDateRng = GetMyScheduleRng
Else
'個別年間行事の次の行にずらす
Set getDateRng = getDateRng.offset(1, 0)
End If
'年間行事表に予定がある間ループする
Do While Not getDateRng.Value = ""
'日付が入力されている
If IsDate(getDateRng.Value) = True Then
'表から日付の取得
getDate = getDateRng.Value
'表から毎月設定欄の情報を取得
AllMonthStr = getDateRng.offset(0, 3).Value
'毎月設定欄に〇がついているかの判定用
allMonthChk = StrComp(AllMonthStr, "〇", vbTextCompare)
'同じ月、又は、毎月設定欄が〇なら
If Month(getDate) = Month(ChkDate) Or allMonthChk = 0 Then
'日付の確認
If Day(getDate) = Day(ChkDate) Then
'休日識別欄と予定欄の情報を取得
ScheduleType = getDateRng.offset(0, 1).Text
ScheduleStr = getDateRng.offset(0, 2).Text
IsPrivateSchedule = True
Exit Do
End If
End If
End If
'ひとつ下にずらす
Set getDateRng = getDateRng.offset(1, 0)
Loop
End Function
年間行事表から一致する情報を取得するマクロの解説
引数にByRefを使用しているため、すこしわかりずらいですが、呼び出し元と共有しています。
はじめて呼び出された場合は、年間行事の上から年の情報と月の情報と合致する項目を見つけに行きます。見つかったら、その位置のセル情報をgetDateRngで戻します。
また、見つけた年間行事表の休日識別欄の情報(ScheduleType)と予定欄の情報(ScheduleStr)を呼び出し元にByRef引数で返しています。
次に呼び出されたときは、表の続き(getDateRng.offset(1, 0))から探索しています。Offsetメソッドは、行数、列数の順番に指定して、0は同じ行数や同じ列を表し、offset(1,0)でひとつ下のセルを表します。
シートを複製して、シート名を変更するマクロ
'**********************************************************************
' エクセルシートの複製処理(コピー元・コピー先、共にThisBook内)
'
' ファイル内のシート名「copySheet」を
' 先頭へ複製して名前を変える(newNameSheet)
' 戻り値：複製されたシートオブジェクト
'**********************************************************************
Function CopySheet_inBook(ByVal copySheet As String, _
ByVal newNameSheet As String) As Worksheet
On Error Resume Next
Dim visibleValue As Boolean
visibleValue = ThisWorkbook.Worksheets(copySheet).Visible
'シートを複製
ThisWorkbook.Worksheets(copySheet).Visible = True
ThisWorkbook.Worksheets(copySheet).Copy Before:=Sheets(1)
'シート名の変更
ActiveSheet.Name = newNameSheet
ThisWorkbook.Worksheets(copySheet).Visible = visibleValue
'複製されたシートオブジェクトを返す
Set CopySheet_inBook = ActiveSheet
End Function
シートを複製して、シート名を変更するマクロの解説
コピー元シートの表示/非表示の設定を一旦変数に保存し、表示に切り替える。
コピー後、複製シートのシート名を引数から渡された文字列に変更する
コピー元シートの表示/非表示設定を元に戻して、新しく作成したシートオブジェクトを戻り値として呼び出し元に返します。
カレンダーの内容をウィジット風カレンダーに表示
下記の記事で、このページのカレンダーの内容をウィジット風カレンダーに登録して、マウスオーバー時に表示されるように作成しています。
エクセルカレンダー作成マクロのダウンロード
下記からダウンロードしたエクセルファイルを起動し、コンテンツの有効化を行う。
マクロの有効化手順については、こちらも参考にしてください。
祝日のメンテナンス方法については、国民の祝日を取得するエクセルマクロ(Excel VBA)にて確認をしてください。