休日祝日判定プログラム

WebAPIを使った休日判定

ある日付か休日化かを判定するVBAコードを記述したので以下に紹介する

WebAPIからの一般的な休日の取得

こちらのAPIから年指定でcsvを引っ張ってきてDectionaryに日付をkeyに、祝日名をitemに格納している。
此処は他の言語でも似たようなことができるだろう。

citizenholiday.vba

Private Sub CitizenHoliday(ByRef Dict As Scripting.Dictionary, year As Integer)
    Dim apiname As String
    apiname = Replace("https://holidays-jp.github.io/api/v1/????/date.csv", "????", year)
    Dim csvHttp As MSXML2.XMLHTTP60
    Set csvHttp = New MSXML2.XMLHTTP60
    csvHttp.Open "GET", apiname, False
    csvHttp.send
        If csvHttp.Status = 200 Then
            Call ParseHolidayCSV(csvHttp.responseText(), Dict)
        Else
            MsgBox "HTTPリクエストに失敗しました。ステータスコード: " & csvHttp.Status
        End If
End Sub

Sub ParseHolidayCSV(response As String, ByRef holidays As Scripting.Dictionary)
    Dim rows() As String
    rows = Split(response, vbLf) ' 行に分割
    
    Dim r As Long
    'UBound(rows) - 1はAPIが返すデータの末尾にもLFが付いているための対策
    For r = LBound(rows) To UBound(rows) - 1
        Dim cells() As String
        cells = Split(rows(r), ",") ' セルに分割

        If IsDate(cells(0)) = True Then
           Call AddDate2Dict(holidays, CDate(cells(0)), cells(1)) ' 日付をキー、祝日名を値として格納
        End If
    Next r
End Sub

Private Sub AddDate2Dict(ByRef Dict As Scripting.Dictionary, dayKey As Date, item As String)
    ' キーが辞書に存在するかどうかをチェック
    If Not Dict.Exists(dayKey) Then
        ' キーが存在しない場合、新たに追加
        Dict.Add dayKey, item
    Else
        ' キーが既に存在する場合、既存のデータを上書きする
        Dict(dayKey) = item
        
        ' 必要に応じてエラーメッセージを表示する
        MsgBox "指定された日付はすでに祝日リストに存在します: " & dayKey & " " & item, vbExclamation, "データ追加エラー"
    End If
End Sub

サービス休日判定

今回の案件では土日または祝日がサービス休業日だったので以下のコードで判定する。
サービス休業日の場合にtrueを返すようになっている。

IsServiceClosed.vba

'Is ServiceClosedのDictは外から挿入する。Dictの型はScriptingDictionaryである。
Function IsServiceClosed(day As Date, ByRef Dict As Scripting.Dictionary) As Boolean
    If Weekday(day) = vbSunday Or Weekday(day) = vbSaturday Then '土日ならTrueを返す
        IsServiceClosed = True
        Exit Function
    End If
    If Dict.Exists(day) Then '休日Dictに在るならFalseを返す
            IsServiceClosed = True
        Else
            IsServiceClosed = False
    End If
End Function

##実用例　出席簿の斜線引き
ではこの関数を使った実践例として半月分の出席簿の斜線を引くコードを以下に示す。

attendance_constructor.vba

Private Sub attendance_constructor(targetday As Date, holidays As Scripting.Dictionary)
On Error GoTo CleanUp
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
With Worksheets("出席簿")
    .Range("G1").Value = "氏名" '名前を空白にする
    .Range("C2").Value = year(targetday) '年を設定
    '月を設定
    Dim monthcell As Range
    Set monthcell = .cells(3, 3)
    
    Dim initmonth As Integer
    If month(targetday) > 6 Then '6月から11月は下期扱い
        initmonth = 7 '下期の開始は7月
    Else
        initmonth = 1 '上期の開始は1月
    End If
    Dim trgmonth As Integer
    For trgmonth = initmonth To initmonth + 5
        monthcell.Value = trgmonth
        Dim day As Integer
        For day = 1 To 31
            Dim isclosed As Boolean
            Dim celldate As Date
            celldate = DateSerial(.Range("C2").Value, trgmonth, day)
            isclosed = IsServiceClosed(celldate, holidays)
            If trgmonth <> month(celldate) Then '別月判定
                isclosed = True '別月なら斜線判定
            End If
            
            If isclosed Then
                .cells(day + 3, monthcell.Column).Borders(xlDiagonalDown).LineStyle = xlContinuous
            Else
                .cells(day + 3, monthcell.Column).Borders(xlDiagonalDown).LineStyle = xlLineStyleNone
            End If
        Next day
        Set monthcell = monthcell.Offset(0, 1)
    Next trgmonth
    'B3:H34に格子枠線を設定しなおす。
    .Range("B3:H34").Borders.LineStyle = xlContinuous
End With
CleanUp:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then MsgBox "エラーが発生しました: " & Err.Description
End Sub