７月の最終金曜日を求める の続き

先日、「７月の最終金曜日を求める」をテーマにお話ししました。

infoment.hatenablog.com

後日続編として「金曜日が休日の場合、その１週間前を最終金曜日とする」をテーマに勉強会を開催したので紹介します。

まず、金曜日がお休みとなる条件は、主に以下の通りです。

• その年の祝日と重なる場合
• 個別組織の休日である場合（勤め先など）
• 有給などの休暇である場合（個人の予定）

これらを最初から Excelが知るはずもなく、なんらかの手段で Excel に伝える必要があります。今回は、「カレンダーテーブル」シートを作成しようということになりました。

※ブログ用のダミーカレンダーです。
※仮に、8/31金を休日としています。本当になればいいのに。

一旦求めた最終金曜日について、以下の判断をすることになります。

• カレンダーに記載有り　⇒　一週間前を最終金曜日とする
• カレンダーに記載なし　⇒　最初に求めた日が最終金曜日

この考えに基づき、皆でワイワイガヤガヤと議論しながら、マクロを一つ作成しました。本日、私の方でブログ用に書き直したものがこちらです。

Option Explicit

Function GetLastFriday(target_date As Date) As Date
    
    ' 最終金曜日を取得。
    Dim NextMonthFirstDay As Date
        NextMonthFirstDay = DateSerial(Year(target_date), Month(target_date) + 1, 1)
        GetLastFriday = NextMonthFirstDay - Weekday(NextMonthFirstDay, vbSaturday)
        
    ' カレンダー情報を取得。
    Dim Tb As ListObject
        Set Tb = Sheets("カレンダーテーブル").ListObjects(1)
        
    ' カレンダー情報から辞書を作成。
    Dim HolidayDict As Dictionary
        Set HolidayDict = CreateDict(target_table:=Tb, _
                                     key_index:="日付", _
                                     item_index:="勤休区分")
    
    ' 求めた最終金曜日が休日の場合の処理。
        Do
            Select Case HolidayDict.Exists(GetLastFriday)
                Case True
                    If HolidayDict(GetLastFriday) = "休日" Then
                        GetLastFriday = GetLastFriday - 7
                    End If
                Case Else
                    Exit Do
            End Select
        Loop
        
End Function


' ラベルを指定して、テーブル内の２列から辞書（連想配列）を作成。
Function CreateDict(target_table As ListObject, _
                    key_index As Variant, _
                    item_index As Variant) _
                    As Dictionary
    
    ' 辞書の初期化。
    Dim Dict As Dictionary
        Set Dict = New Dictionary
        
    ' 配列：キー格納用
    Dim keySeq As Variant
        keySeq = target_table.ListColumns(key_index).DataBodyRange
        
    ' 配列：アイテム格納用
    Dim itemSeq As Variant
        itemSeq = target_table.ListColumns(item_index).DataBodyRange
        
    ' 各値を辞書にセット。
    Dim i As Long
        For i = LBound(keySeq) To UBound(keySeq)
            Dict(keySeq(i, 1)) = itemSeq(i, 1)
        Next
        
        Set CreateDict = Dict

End Function

仮の休日である 8/31ではなく、その一週間前の金曜日を取得することが出来ました。

ただしこの関数、現時点でわかっている欠点が一つあります。
指定月の金曜日が全て休日の場合、その前の月以前まで日付が戻されてしまう
これはもう、「当月の最終金曜日」とは言えません。しかし日本の法律が変わって金～日の休日が義務化されない限り、そのようなことにはならないと思いましたので、考慮から除外しました。

参考まで。