祝日の文字色変更
カレンダーの土・日・祝日の文字を変更するプログラム。
祝日の定義のシート。
＜祝日の定義＞
| 祝日名 | 月 | 日 | 指定週 | 指定曜日 | 説明 |
| 元日 | 1 | 1 | 年のはじめを祝う。 | ||
| 成人の日 | 1 | 2 | 2 | 1月の第2月曜日。おとなになったことを自覚し、みずから生き抜こうとする青年を祝いはげます。 | |
| 建国記念の日 | 2 | 11 | 建国をしのび、国を愛する心を養う。 | ||
| 天皇誕生日 | 2 | 23 | 天皇の誕生日を祝う。 | ||
| 春分の日 | 3 | 21 | 自然をたたえ、生物をいつくしむ。 | ||
| 昭和の日 | 4 | 29 | 激動の日々を経て、復興を遂げた昭和の時代を顧み、国の将来に思いをいたす。 | ||
| 憲法記念日 | 5 | 3 | 日本国憲法の施行を記念し、国の成長を期する。 | ||
| みどりの日 | 5 | 4 | 自然に親しむとともにその恩恵に感謝し、豊かな心をはぐくむ。 | ||
| こどもの日 | 5 | 5 | こどもの人格を重んじ、こどもの幸福をはかるとともに、母に感謝する。 | ||
| 海の日 | 7 | 3 | 2 | 7月の第3月曜日。海の恩恵に感謝するとともに、海洋国日本の繁栄を願う。 | |
| 山の日 | 8 | 11 | 山に親しむ機会を得て、山の恩恵に感謝する。 | ||
| 敬老の日 | 9 | 3 | 2 | 9月の第3月曜日。多年にわたり社会につくしてきた老人を敬愛し、長寿を祝う。 | |
| 秋分の日 | 9 | 23 | 祖先をうやまい、なくなった人々をしのぶ。 | ||
| スポーツの日 | 10 | 2 | 2 | 10月の第2月曜日。スポーツを楽しみ、他者を尊重する精神を培うとともに、健康で活力ある社会の実現を願う。 | |
| 文化の日 | 11 | 3 | 自由と平和を愛し、文化をすすめる。 | ||
| 勤労感謝の日 | 11 | 23 | 勤労をたっとび、生産を祝い、国民たがいに感謝しあう。 |
＜プログラム＞
'/////////////////////////////////////////
'// 祝日
'/////////////////////////////////////////
Option Explicit
'/****************************************
'/* 独自定数
'/****************************************
Private Const dayFormat = "00"
'Private Const dateFormat = "YYYY/MM/DD"
'Private Const flgOn = "1"
'Private Const flgOff = "0"
'列番号
Private Const weekNameHColNum = 1
Private Const monthHColNum = 2
Private Const dayHColNum = 3
Private Const weekCntHColNum = 4
Private Const weekHColNum = 5
'/****************************************
'/* 独自変数
'/****************************************
'Dim transferFlg As String
'Dim weekCnt As Integer
Dim wArrayDay(31) As Integer
Dim wArrayHoliday() As Variant
'/****************************************
'/* 祝日チェック＆セット
'/****************************************
Public Sub checkAndSetHoliday(wIdx1 As Integer, wWeekNo As Integer, sheetName As String)
'祝日取得
Call getHoliday(Worksheets(sheetName).Cells(startRowNum, monthColNumOri).Value)
Dim i As Integer
For i = LBound(wArrayHoliday) To UBound(wArrayHoliday)
If wArrayHoliday(i, 0) <> 0 Then
'休日は赤文字
If wArrayHoliday(i, 1) = Format(wIdx1, "#") Then
If wWeekNo = 1 Then
'日付固定の休日(日曜日の場合、翌日)
Worksheets(sheetName).Cells(dataDaysRowNumOri - 1, dataWorkStartColNumOri + wIdx1 - 1) = wArrayHoliday(i, 4)
Worksheets(sheetName).Cells(dataDaysRowNumOri - 1, (dataWorkStartColNumOri + wIdx1 - 1) + 1) = "振替"
Worksheets(sheetName).Cells(dataDaysRowNumOri, (dataWorkStartColNumOri + wIdx1 - 1) + 1).Font.Color = RGB(colorNumber255, 0, 0)
Worksheets(sheetName).Cells(dataWeekRowNumOri, (dataWorkStartColNumOri + wIdx1 - 1) + 1).Font.Color = RGB(colorNumber255, 0, 0)
transferFlg = flgOn
Else
'日付固定の休日（日曜日以外の場合）
If Worksheets(sheetName).Cells(dataDaysRowNumOri - 1, dataWorkStartColNumOri + wIdx1 - 1) <> "" Then
'日付固定の連休（GWなどの場合）
Worksheets(sheetName).Cells(dataDaysRowNumOri - 1, (dataWorkStartColNumOri + wIdx1 - 1) + 1) = "振替"
Worksheets(sheetName).Cells(dataDaysRowNumOri, (dataWorkStartColNumOri + wIdx1 - 1) + 1).Font.Color = RGB(colorNumber255, 0, 0)
Worksheets(sheetName).Cells(dataWeekRowNumOri, (dataWorkStartColNumOri + wIdx1 - 1) + 1).Font.Color = RGB(colorNumber255, 0, 0)
transferFlg = flgOn
End If
Worksheets(sheetName).Cells(dataDaysRowNumOri - 1, dataWorkStartColNumOri + wIdx1 - 1) = wArrayHoliday(i, 4)
Worksheets(sheetName).Cells(dataDaysRowNumOri, dataWorkStartColNumOri + wIdx1 - 1).Font.Color = RGB(colorNumber255, 0, 0)
Worksheets(sheetName).Cells(dataWeekRowNumOri, dataWorkStartColNumOri + wIdx1 - 1).Font.Color = RGB(colorNumber255, 0, 0)
End If
ElseIf wArrayHoliday(i, 1) = 0 And wArrayHoliday(i, 2) = weekCnt And wArrayHoliday(i, 3) = wWeekNo Then
'第●週の休日
Worksheets(sheetName).Cells(dataDaysRowNumOri - 1, dataWorkStartColNumOri + wIdx1 - 1) = wArrayHoliday(i, 4)
Worksheets(sheetName).Cells(dataDaysRowNumOri, dataWorkStartColNumOri + wIdx1 - 1).Font.Color = RGB(colorNumber255, 0, 0)
Worksheets(sheetName).Cells(dataWeekRowNumOri, dataWorkStartColNumOri + wIdx1 - 1).Font.Color = RGB(colorNumber255, 0, 0)
End If
End If
Next i
End Sub
'/****************************************
'/* 対象月の祝日取得
'/* ※祝日が変わった場合は、祝日シートの記載を変更するだけ。PGは修正不要。
'/****************************************
Private Sub getHoliday(targetMonth As Integer)
'表示＆保護解除
Worksheets(holidaySheet).Visible = True
Worksheets(holidaySheet).Select
Worksheets(holidaySheet).Unprotect
Dim wHoliday As String
Dim wCnt As Integer
Dim wWeek As String
Dim i As Long
maxRowNum = getLastRowOrColNum(holidaySheet, startColNum, flgOff)
ReDim wArrayHoliday(maxRowNum, 5) As Variant
For i = 2 To maxRowNum
'表示月
If targetMonth = Cells(i, monthHColNum).Value Then
'祝日
wArrayHoliday(i - 2, 0) = Cells(i, monthHColNum).Value
wArrayHoliday(i - 2, 1) = Cells(i, dayHColNum).Value
wArrayHoliday(i - 2, 2) = Cells(i, weekCntHColNum).Value
wArrayHoliday(i - 2, 3) = Cells(i, weekHColNum).Value
wArrayHoliday(i - 2, 4) = Cells(i, weekNameHColNum).Value
End If
Next i
'保護＆非表示
Call protectAndHiddenSheet(holidaySheet, CreateWorkTableSheet)
End Sub
ファイル削除を改良
１週間分だけ保持するように変更。
Private Sub trushClear(backupPath As String, objFSO As Object)
'バックアップフォルダの存在チェック
If Dir(backupPath, vbDirectory) = "" Then
MkDir backupPath
End If
'指定したフォルダパスとファイル名をセットする
Dim setPath As String
setPath = Dir(backupPath & "\残したいファイル_*.xlsm")
'バックアップ日付
Dim bkDate As String
'ファイル名が取得出来なくなるまでループ
Do While setPath <> ""
'ファイル名によって開始位置は変わる
bkDate = Mid(setPath, 9, 8)
'※ファイル名にバックアップした日付をつける
If bkDate < Format(Date - 7, "yyyymmdd") Then
Kill backupPath & "\" & Format(Date, "yyyymmdd") & "残したいファイル_*.xlsm"
’ MsgBox "ファイル：" & setPath & " 日付：" & bkDate
End If
setPath = Dir()
Loop
End Sub
ファイルのバックアップ作成
ボタンを押すとファイルをバックアップするプログラム。
＜プログラム＞
Private Sub BackUp_Click()
On Error Resume Next
ThisWorkbook.Save
If Err.Number <= 0 Then
'デスクトップにバックアップフォルダを作成した場合
Dim backupPath As String
backupPath = "C:\Users\" & Application.UserName & "\Desktop\" & Format(Date,"YYYY") & "_bk"
'古いバックアップを消す
Call trushClear(backupPath)
'ファイル移動オブジェクト（複数用）
Dim objFSO As Object, txtSource As String, txtDestination
Set objFSO = CreateObject("Scripting.FileSystemObject")
'バックアップのコピー
Call copyNewBk(objFSO)
End If
End Sub
Private Sub trushClear(backupPath As String)
'バックアップフォルダの存在チェック
If Dir(backupPath, vbDirectory) = "" Then
MkDir backupPath
End If
'※ファイル名は任意
If Dir(backupPath & "\" & Format(Date, "yyyymmdd") & "残したいファイル_*.xlsm") <> "" Then
Kill backupPath & "\" & Format(Date, "yyyymmdd") & "残したいファイル_*.xlsm"
End If
End Sub
Private Sub copyNewBk(backupPath As String, objFSO As Object)
'残したいファイル ※objFSO.CopyFileは、開いていてもコピーできる（最後に保存されたタイミングのコピーとなる）
objFSO.CopyFile ThisWorkbook.FullName, backupPath & "\残したいファイル_" & Format(Date, "yyyymmdd") & ".xlsm"
' '参考 ※FileCopyは、開いているファイルはコピーできない
' FileCopy "バックアップを取りたいファイルが置かれているフォルダ/" & "\残したいファイル_" & Format(Date, "yyyymmdd") & ".xlsm", backupPath & "\残したいファイル_" & Format(Date, "yyyymmdd") & ".xlsm"
End Sub
＜オマケ＞
ファイルをカウントする。
Private Function countFile(filePath As String, fileName As String) As Long
Dim cnt As Long
Dim tmp As String
cnt = 1
tmp = Dir(filePath & "\" & fileName)
Do While tmp <> ""
cnt = cnt + 1
tmp = Dir()
Loop
countFile = cnt
End Function
