祝日の文字色変更

カレンダーの土・日・祝日の文字を変更するプログラム。

祝日の定義のシート。

＜祝日の定義＞

祝日名	月	日	指定週	指定曜日	説明
元日	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