Option Explicit ' ========================================================================= ' Sub: CreateAutoColorCalendar ' Desc: 年月入力で自動更新される土日祝色分けカレンダーを作成する ' Usage: このマクロを実行すると、アクティブシートにカレンダーが設定されます。 ' Note: 事前に「祝日リストシート」が存在しない場合は新規作成されます。 ' 祝日データは「祝日リストシート」のA列に日付形式で入力してください。 ' ========================================================================= Sub CreateAutoColorCalendar() ' --- 定数定義 --- 10 Const CALENDAR_SHEET_NAME As String = "カレンダー" ' カレンダーを作成するシート名 (アクティブシートを使用する場合は不要) 20 Const HOLIDAY_LIST_SHEET_NAME As String = "祝日リストシート" 30 Const HOLIDAY_LIST_NAME As String = "祝日リスト" 40 Dim wsCalendar As Worksheet 50 Dim wsHoliday As Worksheet 60 Dim rngCalendar As Range 70 Dim rngHolidayList As Range 80 Dim lastRow As Long 90 Dim i As Long 100 Dim fc As FormatCondition ' --- エラーハンドリング設定 --- 110 On Error GoTo ErrorHandler ' --- 画面更新停止 (処理高速化) --- 120 Application.ScreenUpdating = False ' --- カレンダーシートの設定 --- 130 Set wsCalendar = ActiveSheet ' アクティブシートをカレンダーシートとする ' 必要であれば特定のシート名で設定 ' On Error Resume Next ' Set wsCalendar = ThisWorkbook.Worksheets(CALENDAR_SHEET_NAME) ' On Error GoTo ErrorHandler ' If wsCalendar Is Nothing Then ' MsgBox CALENDAR_SHEET_NAME & " が見つかりません。", vbExclamation ' GoTo CleanUp ' End If ' wsCalendar.Activate ' 対象シートをアクティブにする ' --- 年月入力セルと曜日ヘッダーの設定 --- 140 wsCalendar.Range("B1").Value = Year(Date) ' 初期値として当年 150 wsCalendar.Range("C1").Value = "年" 160 wsCalendar.Range("D1").Value = Month(Date) ' 初期値として当月 170 wsCalendar.Range("E1").Value = "月" 180 wsCalendar.Range("B3:H3").Value = Array("月", "火", "水", "木", "金", "土", "日") ' --- カレンダー表示エリアの数式設定 --- 190 Set rngCalendar = wsCalendar.Range("B4:H9") 200 wsCalendar.Range("B4").Formula = "=DATE($B$1,$D$1,1)-WEEKDAY(DATE($B$1,$D$1,1),2)+1" 210 wsCalendar.Range("C4:H4").Formula = "=B4+1" 220 wsCalendar.Range("B5:H9").Formula = "=B4+7" ' --- カレンダー表示エリアの表示形式設定 --- 230 rngCalendar.NumberFormatLocal = "d" ' --- 祝日リストシートの準備 --- 240 On Error Resume Next ' シート存在チェックのため一時的にエラー無視 250 Set wsHoliday = ThisWorkbook.Worksheets(HOLIDAY_LIST_SHEET_NAME) 260 On Error GoTo ErrorHandler ' エラーハンドリングを元に戻す 270 If wsHoliday Is Nothing Then ' シートが存在しない場合 280 Set wsHoliday = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) 290 wsHoliday.Name = HOLIDAY_LIST_SHEET_NAME 300 wsHoliday.Range("A1").Value = "祝日日付" ' ヘッダー ' --- サンプル祝日データの入力 (必要に応じて) --- 310 wsHoliday.Range("A2").Value = DateSerial(Year(Date), 1, 1) ' 例: 元日 320 wsHoliday.Range("A3").Value = DateSerial(Year(Date), 5, 5) ' 例: こどもの日 330 wsHoliday.Range("A2:A3").NumberFormatLocal = "yyyy/m/d" ' 日付形式に 340 MsgBox "「" & HOLIDAY_LIST_SHEET_NAME & "」を新規作成しました。" & vbCrLf & _ "A列に祝日の一覧を日付形式 (例: 2024/1/1) で入力してください。", vbInformation 350 Else ' シートが既に存在する場合の処理 (必要であれば) 360 End If ' --- 祝日リストの名前定義 --- 370 lastRow = wsHoliday.Cells(wsHoliday.Rows.Count, "A").End(xlUp).Row 380 If lastRow < 2 Then ' ヘッダーのみ、またはデータがない場合 390 MsgBox "「" & HOLIDAY_LIST_SHEET_NAME & "」のA列に祝日データが見つかりません。" & vbCrLf & _ "祝日の色分けは機能しません。データを入力後、再度マクロを実行するか、手動で名前定義を行ってください。", vbExclamation 400 Else 410 Set rngHolidayList = wsHoliday.Range("A2:A" & lastRow) 420 On Error Resume Next ' 既存の名前定義削除のため一時的にエラー無視 430 ThisWorkbook.Names(HOLIDAY_LIST_NAME).Delete 440 On Error GoTo ErrorHandler ' エラーハンドリングを元に戻す 450 ThisWorkbook.Names.Add Name:=HOLIDAY_LIST_NAME, RefersTo:="=" & wsHoliday.Name & "!" & rngHolidayList.Address 460 End If ' --- 条件付き書式の設定 --- 470 rngCalendar.FormatConditions.Delete ' 既存のルールをクリア ' --- ルール4: 当月以外の日付 (灰色文字) --- 480 Set fc = rngCalendar.FormatConditions.Add(Type:=xlExpression, Formula1:="=MONTH(B4)<>$D$1") 490 With fc.Font 500 .Color = RGB(160, 160, 160) ' 灰色 510 .TintAndShade = 0 520 End With 530 fc.StopIfTrue = False ' 他のルールも評価する ' --- ルール3: 土曜日 (青文字、薄い青背景) --- 540 Set fc = rngCalendar.FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(B4,2)=6") 550 With fc 560 With .Font 570 .Color = RGB(0, 0, 255) ' 青色 580 .TintAndShade = 0 590 End With 600 With .Interior 610 .PatternColorIndex = xlAutomatic 620 .Color = RGB(217, 225, 242) ' 薄い青色 (例) 630 .TintAndShade = 0 640 End With 650 End With 660 fc.StopIfTrue = False ' 祝日や日曜日のルールを優先させるためFalseのまま ' --- ルール2: 日曜日 (赤文字、薄い赤背景) --- 670 Set fc = rngCalendar.FormatConditions.Add(Type:=xlExpression, Formula1:="=WEEKDAY(B4,2)=7") 680 With fc 690 With .Font 700 .Color = RGB(255, 0, 0) ' 赤色 710 .TintAndShade = 0 720 End With 730 With .Interior 740 .PatternColorIndex = xlAutomatic 750 .Color = RGB(255, 218, 218) ' 薄い赤色 (例) 760 .TintAndShade = 0 770 End With 780 End With 790 fc.StopIfTrue = False ' 祝日ルールを優先させるためFalseのまま ' --- ルール1: 祝日 (濃い赤背景) --- 800 If Not rngHolidayList Is Nothing Then ' 祝日リストが定義されている場合のみ設定 810 Set fc = rngCalendar.FormatConditions.Add(Type:=xlExpression, Formula1:="=COUNTIF(" & HOLIDAY_LIST_NAME & ",B4)>0") 820 With fc.Interior 830 .PatternColorIndex = xlAutomatic 840 .Color = RGB(255, 102, 102) ' 濃い目の赤 (例) 850 .TintAndShade = 0 860 End With ' 祝日の文字色も変更したい場合はここに追加 ' With fc.Font ' .Color = vbWhite ' 例: 白文字 ' End With 870 fc.StopIfTrue = True ' 祝日は最優先なので、ここで評価を止める 880 End If ' --- 仕上げ --- 890 wsCalendar.Activate 900 wsCalendar.Range("B1").Select ' 年入力セルを選択状態にする CleanUp: ' --- 画面更新再開 --- 910 Application.ScreenUpdating = True 920 Set wsCalendar = Nothing 930 Set wsHoliday = Nothing 940 Set rngCalendar = Nothing 950 Set rngHolidayList = Nothing 960 Set fc = Nothing 970 MsgBox "自動色分けカレンダーの設定が完了しました。", vbInformation 980 Exit Sub ' 正常終了 ErrorHandler: ' --- エラー処理 --- 990 MsgBox "エラーが発生しました。" & vbCrLf & _ "エラー番号: " & Err.Number & vbCrLf & _ "エラー内容: " & Err.Description & vbCrLf & _ "発生行番号: " & Erl, vbCritical, "エラー" 1000 Resume CleanUp ' クリーンアップ処理へ End Sub