VBAによる「祝日判定処理」を「休日判定処理」に拡張してみた

3ヶ月半ほど前の5月28日に、VBAの祝日判定コードを書いたところ思っていた以上にアクセスされているようで、「以外に需要があるものだ」と少々驚いています。(推定で平日30件たらず?ですけど・・・)

そこで、図に乗った空腹おやじは、前回の祝日判定を拡張し、休日判定出来るようにすることにしました。(「休日でなければ・・・」という判定をすれば、営業日とか稼働日の判定にも使えそうです。)

基本は、前回の祝日判定処理を利用して、祝日定義同様に

  • 月日固定の休日
  • 月週曜日固定の休日
  • 曜日固定の休日

を定義する処理を追加し、祝日判定の時と同様に日付指定でBool値判定。

更に、

  • 特定の祝日、休日を除外できるようにする

といったところでしょうか。

クラスモジュール(CCompanyHoliday)のソースは、長いので下の方に・・・

とりあえず祝日定義は、祝日法が変わらなければ、いじる必要が必要ないと思うので
まずは、休日定義を以下の6個のメソッド内で設定してから使ってみてください。

  • getCompanyHolidayInfoW(曜日固定の会社休日情報生成)
  • getCompanyHolidayInfoMD(月日固定の会社休日情報生成)
  • getCompanyHolidayInfoWN(月週曜日固定の会社休日情報生成)
  • getCompanyHolidayInfoMDExclude(月日固定の会社出勤情報生成)
  • getCompanyHolidayInfoWNExclude(月週曜日固定の会社出勤情報生成)

実行例は、こんな感じ。

Public Sub Test(ByVal lYear As Long)

    Dim cch     As CCompanyHoliday
    Dim dt()    As Date
    Dim i As Long

    Set cch = New CCompanyHoliday

    Call cch.getNationalHolidays(lYear, dt)

    For i = 0 To UBound(dt)
        Debug.Print dt(i), cch.getNationalHolidayName(dt(i))
    Next i

    Set cch = Nothing

End Sub

これをイミディエイトウィンドウで実行してみると

call Test(2018)
2018/01/01 元日
2018/01/02 年始休暇
2018/01/03 年始休暇
2018/01/06 会社休日
2018/01/07 会社休日
2018/01/08 成人の日
2018/01/13 会社休日
2018/01/14 会社休日
2018/01/20 会社休日
2018/01/21 会社休日
2018/01/27 会社休日
2018/01/28 会社休日
2018/02/03 会社休日
2018/02/04 会社休日
2018/02/10 会社休日
2018/02/11 建国記念の日
2018/02/12 振替休日
2018/02/17 会社休日
2018/02/18 会社休日
2018/02/24 会社休日
2018/02/25 会社休日
2018/03/03 会社休日
2018/03/04 会社休日
2018/03/10 会社休日
2018/03/11 会社休日
2018/03/17 会社休日
2018/03/18 会社休日
2018/03/21 春分の日
2018/03/24 会社休日
2018/03/25 会社休日
2018/03/31 会社休日
2018/04/01 会社休日
2018/04/07 会社休日
2018/04/08 会社休日
2018/04/14 会社休日
2018/04/15 会社休日
2018/04/21 会社休日
2018/04/22 会社休日
2018/04/28 会社休日
2018/04/30 振替休日
2018/05/03 憲法記念日
2018/05/04 みどりの日
2018/05/05 こどもの日
2018/05/06 会社休日
2018/05/12 会社休日
2018/05/13 会社休日
2018/05/19 会社休日
2018/05/20 会社休日
2018/05/26 会社休日
2018/05/27 会社休日
2018/06/02 会社休日
2018/06/03 会社休日
2018/06/09 会社休日
2018/06/10 会社休日
2018/06/16 会社休日
2018/06/17 会社休日
2018/06/18 特別休日
2018/06/23 会社休日
2018/06/24 会社休日
2018/06/30 会社休日
2018/07/01 会社休日
2018/07/07 会社休日
2018/07/08 会社休日
2018/07/14 会社休日
2018/07/15 会社休日
2018/07/16 海の日
2018/07/21 会社休日
2018/07/22 会社休日
2018/07/28 会社休日
2018/07/29 会社休日
2018/08/04 会社休日
2018/08/05 会社休日
2018/08/11 山の日
2018/08/12 お盆休暇
2018/08/13 お盆休暇
2018/08/14 お盆休暇
2018/08/15 お盆休暇
2018/08/16 お盆休暇
2018/08/17 お盆休暇
2018/08/18 お盆休暇
2018/08/19 会社休日
2018/08/26 会社休日
2018/09/01 創業記念日
2018/09/02 会社休日
2018/09/08 会社休日
2018/09/09 会社休日
2018/09/15 会社休日
2018/09/16 会社休日
2018/09/17 敬老の日
2018/09/22 会社休日
2018/09/23 秋分の日
2018/09/24 振替休日
2018/09/29 会社休日
2018/09/30 会社休日
2018/10/06 会社休日
2018/10/07 会社休日
2018/10/08 体育の日
2018/10/13 会社休日
2018/10/14 会社休日
2018/10/20 会社休日
2018/10/21 会社休日
2018/10/24 特別休日
2018/10/25 特別休日
2018/10/27 会社休日
2018/10/28 会社休日
2018/11/03 文化の日
2018/11/04 会社休日
2018/11/10 会社休日
2018/11/11 会社休日
2018/11/17 会社休日
2018/11/18 会社休日
2018/11/23 勤労感謝の日
2018/11/24 会社休日
2018/11/25 会社休日
2018/12/01 会社休日
2018/12/02 会社休日
2018/12/08 会社休日
2018/12/09 会社休日
2018/12/15 会社休日
2018/12/16 会社休日
2018/12/22 会社休日
2018/12/23 天皇誕生日
2018/12/24 振替休日
2018/12/29 年末休暇
2018/12/30 年末休暇
2018/12/31 年末休暇


クラスモジュール(CCompanyHoliday)のソースは、これ

Option Explicit

'//////////////////////////////////////////////////
'                   概  要
'//////////////////////////////////////////////////
'
'用   途:会社休日取得、確認用
'処理対象日:1948/7/20以降(2050年までは、春分の日、秋分の日確認済み)
'備   考:2020/2/23天皇誕生日対応済み
'            改正東京五輪・パラリンピック特別措置法(2018/6/13参議院本会議可決分)対応済み
'作   成:2018/9/9


'//////////////////////////////////////////////////
'                   参照設定
'//////////////////////////////////////////////////

'Dictionary用
'Microsoft Scripting Runtime


'//////////////////////////////////////////////////
'                ユーザー定義型
'//////////////////////////////////////////////////

'月日固定の祝日情報
Private Type FixMD
    sMD         As String
    lBeginYear  As Long
    lEndYear    As Long
    sName       As String
End Type

'月週曜日固定の祝日情報
Private Type FixWN
    lMonth      As Long
    lNthWeek    As Long
    lDayOfWeek  As Long
    lBeginYear  As Long
    lEndYear    As Long
    sName       As String
End Type

'月日固定の会社休日情報
Private Type FixMDC
    sMD         As String
    lDays       As Long
    lBeginYear  As Long
    lEndYear    As Long
    sName       As String
End Type

'月週曜日固定の会社休日情報
Private Type FixWNC
    lMonth      As Long
    lNthWeek    As Long
    lDayOfWeek  As Long
    lDays       As Long
    lBeginYear  As Long
    lEndYear    As Long
    sName       As String
End Type

'//////////////////////////////////////////////////
'                   定数
'//////////////////////////////////////////////////

'「国民の祝日に関する法律」施行年月日
Private Const BEGIN_DATE    As Date = #7/20/1948#

'「振替休日」施行年月日
Private Const TRANSFER_HOLIDAY1_BEGIN_DATE    As Date = #4/12/1973#
Private Const TRANSFER_HOLIDAY2_BEGIN_DATE    As Date = #1/1/2007#

'「国民の休日」施行年月日
Private Const NATIONAL_HOLIDAY_BEGIN_DATE       As Date = #12/27/1985#

'年上限
Private Const YEAR_MAX      As Long = 2050

'エラーコード(パラメータ異常)
Private Const ERROR_INVALID_PARAMETER   As Long = &H57


'//////////////////////////////////////////////////
'               Private変数
'//////////////////////////////////////////////////

'国民の祝日格納用ディクショナリ
'キー:年月日(DateTime型)
'値 :祝日名
Private dicHoliday_ As New Dictionary

Private lInitializedLastYear_   As Long


'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
'                       祝日情報の定義
'
' 基本的な祝日情報は、以下の2つのメソッド内で定義する。
'  getNationalHolidayInfoMD
'  getNationalHolidayInfoWN
'
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

'//////////////////////////////////////////////////
'月日固定の祝日情報生成
'//////////////////////////////////////////////////
Private Sub getNationalHolidayInfoMD(ByRef uFixMD() As FixMD)

    Dim sFixMD(24)  As String   '祝日データを追加削除した場合、この配列要素数を変更すること
    Dim sResult()   As String
    Dim i           As Long

    '//////////////////////////////////////////////////
    '               月日固定の祝日
    '//////////////////////////////////////////////////
    '適用開始年について
    ' 元旦(1/1)
    ' 成人の日(1/15)
    ' 天皇誕生日(4/29)
    ' 憲法記念日(5/3)
    ' こどもの日(5/5)
    'の5つは、「国民の祝日に関する法律」施行年(1948年)に制定されているが
    '同法の施行が7/20であり、それ以前となるため、適用開始年を翌年(1949年)に補正してある。
    '
    '月日,適用開始年,適用終了年,名前
    '適用終了年;9999は、現在も適用中
    sFixMD(0) = "01/01,1949,9999,元日"          '適用開始年補正済み
    sFixMD(1) = "01/15,1949,1999,成人の日"      '適用開始年補正済み
    sFixMD(2) = "02/11,1967,9999,建国記念の日"
    sFixMD(3) = "02/23,2020,9999,天皇誕生日"    '適用開始年補正済み
    sFixMD(4) = "02/24,1989,1989,昭和天皇の大喪の礼"
    sFixMD(5) = "04/10,1959,1959,皇太子明仁親王の結婚の儀"
    sFixMD(6) = "04/29,1949,1988,天皇誕生日"    '適用開始年補正済み
    sFixMD(7) = "04/29,1989,2006,みどりの日"
    sFixMD(8) = "04/29,2007,9999,昭和の日"
    sFixMD(9) = "05/03,1949,9999,憲法記念日"    '適用開始年補正済み
    sFixMD(10) = "05/04,2007,9999,みどりの日"
    sFixMD(11) = "05/05,1949,9999,こどもの日"    '適用開始年補正済み
    sFixMD(12) = "06/09,1993,1993,皇太子徳仁親王の結婚の儀"
    sFixMD(13) = "07/20,1996,2002,海の日"
    sFixMD(14) = "07/23,2020,2020,海の日"
    sFixMD(15) = "07/24,2020,2020,スポーツの日"
    sFixMD(16) = "08/10,2020,2020,山の日"
    sFixMD(17) = "08/11,2016,2019,山の日"
    sFixMD(18) = "08/11,2021,9999,山の日"
    sFixMD(19) = "09/15,1966,2002,敬老の日"
    sFixMD(20) = "10/10,1966,1999,体育の日"
    sFixMD(21) = "11/03,1948,9999,文化の日"
    sFixMD(22) = "11/12,1990,1990,即位礼正殿の儀"
    sFixMD(23) = "11/23,1948,9999,勤労感謝の日"
    sFixMD(24) = "12/23,1989,2018,天皇誕生日"

    ReDim uFixMD(UBound(sFixMD))

    For i = 0 To UBound(sFixMD)
        sResult = Split(sFixMD(i), ",")

        uFixMD(i).sMD = sResult(0)
        uFixMD(i).lBeginYear = CLng(sResult(1))
        uFixMD(i).lEndYear = CLng(sResult(2))
        uFixMD(i).sName = sResult(3)
    Next i

End Sub

'//////////////////////////////////////////////////
'月週曜日固定の祝日情報生成
'//////////////////////////////////////////////////
Private Sub getNationalHolidayInfoWN(ByRef uFixWN() As FixWN)

    Dim sFixWN(5)   As String   '祝日データを追加削除した場合、この配列要素数を変更すること
    Dim sResult()   As String
    Dim i           As Long

    '//////////////////////////////////////////////////
    '               月週曜日固定の祝日
    '//////////////////////////////////////////////////
    '月,週,曜日,適用開始年,適用終了年,名前
    '曜日:日 1
    '   月 2
    '   火 3
    '   水 4
    '   木 5
    '   金 6
    '   土 7
    '適用終了年;9999は、現在も適用中
    sFixWN(0) = "01,2,2,2000,9999,成人の日"
    sFixWN(1) = "07,3,2,2003,2019,海の日"
    sFixWN(2) = "07,3,2,2021,9999,海の日"
    sFixWN(3) = "09,3,2,2003,9999,敬老の日"
    sFixWN(4) = "10,2,2,2000,2019,体育の日"
    sFixWN(5) = "10,2,2,2021,9999,スポーツの日"

    ReDim uFixWN(UBound(sFixWN))

    For i = 0 To UBound(sFixWN)
        sResult = Split(sFixWN(i), ",")

        uFixWN(i).lMonth = CLng(sResult(0))
        uFixWN(i).lNthWeek = CLng(sResult(1))
        uFixWN(i).lDayOfWeek = CLng(sResult(2))
        uFixWN(i).lBeginYear = CLng(sResult(3))
        uFixWN(i).lEndYear = CLng(sResult(4))
        uFixWN(i).sName = sResult(5)
    Next i

End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'                       祝日情報の定義 ここまで
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
'                       会社休日情報の定義
'
' 基本的な会社休日情報は、以下の5個のメソッド内で定義する。
'   getCompanyHolidayInfoW
'   getCompanyHolidayInfoMD
'   getCompanyHolidayInfoWN
'   getCompanyHolidayInfoMDExclude
'   getCompanyHolidayInfoWNExclude
'
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

'//////////////////////////////////////////////////
'曜日固定の会社休日情報生成
'//////////////////////////////////////////////////
Private Sub getCompanyHolidayInfoW(ByRef isHolidayArry() As Boolean)

    Dim isHolidayW(6)   As Boolean
    Dim i               As Long

    isHolidayW(0) = True        '日曜日
    isHolidayW(1) = False       '月曜日
    isHolidayW(2) = False       '火曜日
    isHolidayW(3) = False       '水曜日
    isHolidayW(4) = False       '木曜日
    isHolidayW(5) = False       '金曜日
    isHolidayW(6) = True        '土曜日

    ReDim isHolidayArry(UBound(isHolidayW))

    For i = 0 To UBound(isHolidayW)
        isHolidayArry(i) = isHolidayW(i)
    Next i

End Sub

'//////////////////////////////////////////////////
'月日固定の会社休日情報生成
'//////////////////////////////////////////////////
Private Sub getCompanyHolidayInfoMD(ByRef uFixMDC() As FixMDC)

    Dim sFixMD(3)  As String    '会社休日データを追加削除した場合、この配列要素数を変更すること
    Dim sResult()   As String
    Dim i           As Long

'----対象データがない場合、ReDimのみでExitすること----
'    ReDim uFixMDC(0)
'    Exit Sub
'-----------------------------------------------------

    '//////////////////////////////////////////////////
    '               月日固定の会社休日
    '//////////////////////////////////////////////////
    '適用開始月日,適用日数,適用開始年,適用終了年,名前
    '適用終了年;9999は、現在も適用中
    sFixMD(0) = "01/02,2,1949,9999,年始休暇"
    sFixMD(1) = "09/01,1,1949,9999,創業記念日"
    sFixMD(2) = "12/29,3,1949,9999,年末休暇"
    sFixMD(3) = "08/12,7,1949,2018,お盆休暇"

    ReDim uFixMDC(UBound(sFixMD))

    For i = 0 To UBound(sFixMD)
        sResult = Split(sFixMD(i), ",")

        uFixMDC(i).sMD = sResult(0)
        uFixMDC(i).lDays = CLng(sResult(1))
        uFixMDC(i).lBeginYear = CLng(sResult(2))
        uFixMDC(i).lEndYear = CLng(sResult(3))
        uFixMDC(i).sName = sResult(4)
    Next i

End Sub

'//////////////////////////////////////////////////
'月週曜日固定の会社休日情報生成
'//////////////////////////////////////////////////
Private Sub getCompanyHolidayInfoWN(ByRef uFixWNC() As FixWNC)

    Dim sFixWNC(1)  As String   '会社休日データを追加削除した場合、この配列要素数を変更すること
    Dim sResult()   As String
    Dim i           As Long

'----対象データがない場合、ReDimのみでExitすること----
'    ReDim uFixWNC(0)
'    Exit Sub
'-----------------------------------------------------

    '//////////////////////////////////////////////////
    '               月週曜日固定の会社休日
    '//////////////////////////////////////////////////
    '月,週,曜日,適用日数,適用開始年,適用終了年,名前
    '曜日:日 1
    '   月 2
    '   火 3
    '   水 4
    '   木 5
    '   金 6
    '   土 7
    '適用終了年;9999は、現在も適用中
    sFixWNC(0) = "06,3,2,1,2000,9999,特別休日"
    sFixWNC(1) = "10,4,4,2,2000,9999,特別休日"

    ReDim uFixWNC(UBound(sFixWNC))

    For i = 0 To UBound(sFixWNC)
        sResult = Split(sFixWNC(i), ",")

        uFixWNC(i).lMonth = CLng(sResult(0))
        uFixWNC(i).lNthWeek = CLng(sResult(1))
        uFixWNC(i).lDayOfWeek = CLng(sResult(2))
        uFixWNC(i).lDays = CLng(sResult(3))
        uFixWNC(i).lBeginYear = CLng(sResult(4))
        uFixWNC(i).lEndYear = CLng(sResult(5))
        uFixWNC(i).sName = sResult(6)
    Next i

End Sub

'//////////////////////////////////////////////////
'休日でも出勤する要出勤情報生成
'       月日固定の会社出勤日
'//////////////////////////////////////////////////
Private Sub getCompanyHolidayInfoMDExclude(ByVal lLastYear As Long, ByRef dtExclude() As Date)

    Dim sFixMDC(0)  As String   '会社出勤日データを追加削除した場合、この配列要素数を変更すること
    Dim lElements   As Long
    Dim sResult()   As String
    Dim lDays       As Long
    Dim lYearBegin  As Long
    Dim lYearEnd    As Long
    Dim lYear       As Long
    Dim dtBegin     As Date
    Dim i           As Long
    Dim j           As Long

    lElements = 0
    ReDim dtExclude(lElements)

'----対象データがない場合、ここでExitすること----
'    Exit Sub
'------------------------------------------------

    '//////////////////////////////////////////////////
    '               月日固定の会社出勤日
    '//////////////////////////////////////////////////
    '適用開始月日,適用日数,適用開始年,適用終了年,Reserve
    '適用終了年;9999は、現在も適用中
    sFixMDC(0) = "04/29,1,2000,9999,"

    For i = 0 To UBound(sFixMDC)
        sResult = Split(sFixMDC(i), ",")

        lDays = CLng(sResult(1))

        lYearBegin = CLng(sResult(2))

        lYearEnd = CLng(sResult(3))
        If lYearEnd = 9999 Then
            lYearEnd = lLastYear
        End If

        For lYear = lYearBegin To lYearEnd
            dtBegin = CDate(CStr(lYear) & "/" & sResult(0))

            For j = 0 To lDays - 1
                ReDim Preserve dtExclude(lElements)
                dtExclude(lElements) = DateAdd("d", j, dtBegin)

                lElements = lElements + 1
            Next j
        Next lYear
    Next i

End Sub

'//////////////////////////////////////////////////
'休日でも出勤する要出勤情報生成
'       月週曜日固定の会社出勤日
'//////////////////////////////////////////////////
Private Sub getCompanyHolidayInfoWNExclude(ByVal lLastYear As Long, ByRef dtExclude() As Date)

    Dim sFixWNC(0)  As String   '会社出勤日データを追加削除した場合、この配列要素数を変更すること
    Dim lElements   As Long
    Dim sResult()   As String
    Dim lDays       As Long
    Dim lYearBegin  As Long
    Dim lYearEnd    As Long
    Dim lYear       As Long
    Dim dtBegin     As Date
    Dim i           As Long
    Dim j           As Long

    lElements = 0
    ReDim dtExclude(lElements)

'----対象データがない場合、ここでExitすること----
'    Exit Sub
'-----------------------------------------------------

    '//////////////////////////////////////////////////
    '               月週曜日固定の会社出勤日
    '//////////////////////////////////////////////////
    '月,週,曜日,適用日数,適用開始年,適用終了年,Reserve
    '曜日:日 1
    '   月 2
    '   火 3
    '   水 4
    '   木 5
    '   金 6
    '   土 7
    '適用終了年;9999は、現在も適用中
    sFixWNC(0) = "08,4,7,1,2000,9999,"

    ReDim uFixWNC(UBound(sFixWNC))

    For i = 0 To UBound(sFixWNC)
        sResult = Split(sFixWNC(i), ",")

        lDays = CLng(sResult(3))

        lYearBegin = CLng(sResult(4))

        lYearEnd = CLng(sResult(5))
        If lYearEnd = 9999 Then
            lYearEnd = lLastYear
        End If

        For lYear = lYearBegin To lYearEnd
            dtBegin = getNthWeeksDayOfWeek(CStr(lYear), CLng(sResult(0)), CLng(sResult(1)), CLng(sResult(2)))

            For j = 0 To lDays - 1
                ReDim Preserve dtExclude(lElements)
                dtExclude(lElements) = DateAdd("d", j, dtBegin)

                lElements = lElements + 1
            Next j
        Next lYear
    Next i

End Sub

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'                       会社休日情報の定義 ここまで
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Sub Class_Initialize()

    Set dicHoliday_ = New Dictionary

    lInitializedLastYear_ = &H80000000

    'デフォルトで、現在の5年後までデータを生成する
    InitializedLastYear = Year(Now) + 5

End Sub

Private Sub Class_Terminate()

    Set dicHoliday_ = Nothing

End Sub


'//////////////////////////////////////////////////
'指定日が会社休日か?
'//////////////////////////////////////////////////
Public Function isCompanyHoliday(ByVal dtDate As Date) As Boolean

    Dim dtDateW As Date

    '時分秒データを切り捨てる
    dtDateW = DateSerial(Year(dtDate), Month(dtDate), Day(dtDate))

    If dtDateW < BEGIN_DATE Then
        Err.Raise ERROR_INVALID_PARAMETER, "isCompanyHoliday", Format$(dtDateW, "yyyy/mm/dd") & "は、適用範囲外です。"

        Exit Function
    ElseIf Year(dtDateW) > YEAR_MAX Then
        Err.Raise ERROR_INVALID_PARAMETER, "isCompanyHoliday", Format$(YEAR_MAX + 1, "yyyy年") & "以降は、適用範囲外です。"

        Exit Function
    ElseIf Year(dtDateW) > InitializedLastYear Then
        Err.Raise ERROR_INVALID_PARAMETER, "isCompanyHoliday", Format$(dtDateW, "yyyy年") & "は、データが生成されていないため、判定できません。" _
                            & vbCrLf & "reInitializeメソッドで対象年を設定後、再度確認してみて下さい。"

        Exit Function
    End If

    isCompanyHoliday = dicHoliday_.Exists(dtDateW)

End Function

'//////////////////////////////////////////////////
'指定日が会社休日か?そうであれば、その休日名を合わせて返す
'//////////////////////////////////////////////////
Public Function isCompanyHoliday2(ByVal dtDate As Date, ByRef sHolidayName As String) As Boolean

    Dim dtDateW As Date

    '時分秒データを切り捨てる
    dtDateW = DateSerial(Year(dtDate), Month(dtDate), Day(dtDate))

    isCompanyHoliday2 = isCompanyHoliday(dtDateW)

    sHolidayName = getNationalHolidayName(dtDateW)

End Function

'//////////////////////////////////////////////////
'指定年の会社休日を配列に格納して返す
'//////////////////////////////////////////////////
Public Function getNationalHolidays(ByVal lYear As Long, ByRef dtHolidays() As Date) As Long

    Dim dtHolidaysW()   As Date
    Dim lHolidays       As Long
    Dim i As Long

    lHolidays = 0
    ReDim dtHolidaysW(lHolidays)

    For i = 0 To dicHoliday_.Count - 1
        If Year(dicHoliday_.Keys(i)) = lYear Then
            ReDim Preserve dtHolidaysW(lHolidays)

            dtHolidaysW(lHolidays) = dicHoliday_.Keys(i)

            lHolidays = lHolidays + 1
        End If
    Next i

    '昇順並べ替え
    Call qSort(dtHolidaysW, 0, UBound(dtHolidaysW))

    Erase dtHolidays
    dtHolidays = dtHolidaysW

    getNationalHolidays = lHolidays

End Function

'//////////////////////////////////////////////////
'指定日の会社休日名を返す
'//////////////////////////////////////////////////
Public Function getNationalHolidayName(ByVal dtHoliday As Date) As String

    Dim dtDateW As Date

    '時分秒データを切り捨てる
    dtDateW = DateSerial(Year(dtHoliday), Month(dtHoliday), Day(dtHoliday))

    If isCompanyHoliday(dtDateW) = True Then
        getNationalHolidayName = dicHoliday_.Item(dtDateW)
    End If

End Function

'//////////////////////////////////////////////////
'何年までの会社休日データが生成されているか
'//////////////////////////////////////////////////
Public Property Get InitializedLastYear() As Long

    InitializedLastYear = lInitializedLastYear_

End Property

'//////////////////////////////////////////////////
'指定年までの会社休日データを生成させる(YEAR_MAX以下)
' 外部からの要求は、reInitializeで行うことが出来る
'//////////////////////////////////////////////////
Private Property Let InitializedLastYear(ByVal lInitializedLastYear As Long)

    If lInitializedLastYear < lInitializedLastYear_ Then
        '要求された最終年が初期化済みの年より前ならば、処理しない
        Exit Property
    ElseIf lInitializedLastYear > YEAR_MAX Then
        lInitializedLastYear = YEAR_MAX
    End If

    Call initDictionary(lInitializedLastYear)

    lInitializedLastYear_ = lInitializedLastYear

End Property

'//////////////////////////////////////////////////
'指定年までの会社休日データを生成させる
'//////////////////////////////////////////////////
Public Sub reInitialize(ByVal lLastYear As Long)

    InitializedLastYear = lLastYear

End Sub

'//////////////////////////////////////////////////
'Dictionaryへ会社休日情報を格納
'//////////////////////////////////////////////////
Private Sub initDictionary(ByVal lLastYear As Long)

    Dim uFixMD()    As FixMD
    Dim uFixWN()    As FixWN
    Dim isHolidayArry() As Boolean
    Dim uFixMDC()   As FixMDC
    Dim uFixWNC()   As FixWNC
    Dim dtExclude() As Date

    '月日固定の祝日情報
    Call getNationalHolidayInfoMD(uFixMD)

    '月週曜日固定の祝日情報
    Call getNationalHolidayInfoWN(uFixWN)

    'Dictionaryへ追加
    Call add2Dictionary(lLastYear, uFixMD, uFixWN)


    '曜日固定の会社休日情報
    Call getCompanyHolidayInfoW(isHolidayArry)

    '月日固定の会社休日情報
    Call getCompanyHolidayInfoMD(uFixMDC)

    '月週曜日固定の会社休日情報
    Call getCompanyHolidayInfoWN(uFixWNC)

    'Dictionaryへ追加
    Call add2DictionaryC(lLastYear, uFixMDC, uFixWNC, isHolidayArry)


    '祝日でも出勤する要出勤情報(月日固定)
    Call getCompanyHolidayInfoMDExclude(lLastYear, dtExclude)

    'Dictionaryから要出勤日を除外
    Call removeFromDictionaryC(dtExclude)

    ReDim dtExclude(0)

    '祝日でも出勤する要出勤情報(月週曜日固定)
    Call getCompanyHolidayInfoWNExclude(lLastYear, dtExclude)

    'Dictionaryから要出勤日を除外
    Call removeFromDictionaryC(dtExclude)

End Sub

'//////////////////////////////////////////////////
'祝日情報をDictionaryへ格納
'//////////////////////////////////////////////////
Private Sub add2Dictionary(ByVal lLastYear As Long, ByRef uFixMD() As FixMD, ByRef uFixWN() As FixWN)

    Dim lInitializedLastYear    As Long
    Dim lBeginYear          As Long
    Dim lEndYear            As Long
    Dim dtHoliday           As Date
    Dim lAddedDays          As Long
    Dim dtAdded()           As Date
    Dim existsHoliday       As Boolean
    Dim lYear               As Long
    Dim i                   As Long

    '初期化済みの最終年を取得
    lInitializedLastYear = InitializedLastYear

    If lInitializedLastYear < Year(BEGIN_DATE) Then
        '施工年より前ならば、施工年を開始年とする
        lBeginYear = Year(BEGIN_DATE)
    Else
        '施工年以後なら、初期化済みの翌年を開始年とする
        lBeginYear = lInitializedLastYear + 1
    End If

    lEndYear = lLastYear

    For lYear = lBeginYear To lEndYear
        '年間の祝日格納用配列クリア
        lAddedDays = 0
        ReDim dtAdded(lAddedDays)

        '月日固定の祝日
        For i = 0 To UBound(uFixMD)
            '適用期間のみを対象とする
            If uFixMD(i).lBeginYear <= lYear And uFixMD(i).lEndYear >= lYear Then
                dtHoliday = CDate(CStr(lYear) & "/" & uFixMD(i).sMD)

                dicHoliday_.Add dtHoliday, uFixMD(i).sName

                ReDim Preserve dtAdded(lAddedDays)
                dtAdded(lAddedDays) = dtHoliday
                lAddedDays = lAddedDays + 1
            End If
        Next i

        '月週曜日固定の祝日
        For i = 0 To UBound(uFixWN)
            '適用期間のみを対象とする
            If uFixWN(i).lBeginYear <= lYear And uFixWN(i).lEndYear >= lYear Then
                dtHoliday = getNthWeeksDayOfWeek(lYear, uFixWN(i).lMonth, uFixWN(i).lNthWeek, uFixWN(i).lDayOfWeek)

                dicHoliday_.Add dtHoliday, uFixWN(i).sName

                ReDim Preserve dtAdded(lAddedDays)
                dtAdded(lAddedDays) = dtHoliday
                lAddedDays = lAddedDays + 1
            End If
        Next i

        '春分の日
        dtHoliday = getVernalEquinoxDay(lYear)
        dicHoliday_.Add dtHoliday, "春分の日"

        ReDim Preserve dtAdded(lAddedDays)
        dtAdded(lAddedDays) = dtHoliday
        lAddedDays = lAddedDays + 1

        '秋分の日
        dtHoliday = getAutumnalEquinoxDay(lYear)
        dicHoliday_.Add dtHoliday, "秋分の日"

        ReDim Preserve dtAdded(lAddedDays)
        dtAdded(lAddedDays) = dtHoliday
        lAddedDays = lAddedDays + 1

        '振替休日
        For i = 0 To lAddedDays - 1
            existsHoliday = existsSubstituteHoliday(dtAdded(i), dtHoliday)

            If existsHoliday = True Then
                dicHoliday_.Add dtHoliday, "振替休日"
            End If
        Next i

        '国民の休日
        For i = 0 To lAddedDays - 1
            existsHoliday = existsNationalHoliday(dtAdded(i), dtHoliday)

            If existsHoliday = True Then
                dicHoliday_.Add dtHoliday, "国民の休日"
            End If
        Next i

        Erase dtAdded
    Next lYear

End Sub

'//////////////////////////////////////////////////
'会社休日情報をDictionaryへ格納
'//////////////////////////////////////////////////
Private Sub add2DictionaryC(ByVal lLastYear As Long, ByRef uFixMDC() As FixMDC, ByRef uFixWNC() As FixWNC, ByRef isHolidayArry() As Boolean)

    Dim lInitializedLastYear    As Long
    Dim lBeginYear          As Long
    Dim lEndYear            As Long
    Dim dtHolidayBegin      As Date
    Dim dtHoliday           As Date
    Dim lYear               As Long
    Dim dtBeginDate         As Date
    Dim lDays               As Long
    Dim dtTargetDate        As Date
    Dim i                   As Long
    Dim j                   As Long

    '初期化済みの最終年を取得
    lInitializedLastYear = InitializedLastYear

    If lInitializedLastYear < Year(BEGIN_DATE) Then
        '施工年より前ならば、施工年を開始年とする
        lBeginYear = Year(BEGIN_DATE)
    Else
        '施工年以後なら、初期化済みの翌年を開始年とする
        lBeginYear = lInitializedLastYear + 1
    End If

    lEndYear = lLastYear

    For lYear = lBeginYear To lEndYear
        '月日固定の会社休日
        If uFixMDC(0).sMD Like "##/##" Then
            For i = 0 To UBound(uFixMDC)
                '適用期間のみを対象とする
                If uFixMDC(i).lBeginYear <= lYear And uFixMDC(i).lEndYear >= lYear Then
                    dtHolidayBegin = CDate(CStr(lYear) & "/" & uFixMDC(i).sMD)

                    For j = 0 To uFixMDC(i).lDays - 1
                        dtHoliday = DateAdd("d", j, dtHolidayBegin)

                        'Dictionaryに未登録の場合のみ追加する
                        If dicHoliday_.Exists(dtHoliday) = False Then
                            dicHoliday_.Add dtHoliday, uFixMDC(i).sName
                        End If
                    Next j
                End If
            Next i
        End If

        '月週曜日固定の会社休日
        If uFixWNC(0).lMonth >= 1 And uFixWNC(0).lMonth <= 12 Then
            For i = 0 To UBound(uFixWNC)
                '適用期間のみを対象とする
                If uFixWNC(i).lBeginYear <= lYear And uFixWNC(i).lEndYear >= lYear Then
                    dtHolidayBegin = getNthWeeksDayOfWeek(lYear, uFixWNC(i).lMonth, uFixWNC(i).lNthWeek, uFixWNC(i).lDayOfWeek)

                    For j = 0 To uFixWNC(i).lDays - 1
                        dtHoliday = DateAdd("d", j, dtHolidayBegin)

                        'Dictionaryに未登録の場合のみ追加する
                        If dicHoliday_.Exists(dtHoliday) = False Then
                            dicHoliday_.Add dtHoliday, uFixWNC(i).sName
                        End If
                    Next j
                End If
            Next i
        End If

        '各週固定の会社休日
        dtBeginDate = DateSerial(lYear, 1, 1)
        lDays = DateDiff("d", dtBeginDate, DateSerial(lYear, 12, 31))

        For i = 0 To lDays
            dtTargetDate = DateAdd("d", i, dtBeginDate)

            If isHolidayArry(Weekday(dtTargetDate) - vbSunday) Then
                If dicHoliday_.Exists(dtTargetDate) = False Then
                    dicHoliday_.Add dtTargetDate, "会社休日"
                End If
            End If
        Next i
    Next lYear

End Sub

'//////////////////////////////////////////////////
'会社休日情報をDictionaryから除外
'//////////////////////////////////////////////////
Private Sub removeFromDictionaryC(ByRef dtExclude() As Date)

    Dim i   As Long

    If IsDate(dtExclude(0)) = False Then
        Exit Sub
    End If

    For i = 0 To UBound(dtExclude)
        'Dictionaryに登録済の場合除外する
        If dicHoliday_.Exists(dtExclude(i)) Then
            dicHoliday_.Remove dtExclude(i)
        End If
    Next i

End Sub

'//////////////////////////////////////////////////
'振替休日の有無
' 祝日(dtDate)に対する振替休日の有無(ある場合は、dtSubstituteHolidayに代入される)
'//////////////////////////////////////////////////
Private Function existsSubstituteHoliday(ByVal dtDate As Date, ByRef dtSubstituteHoliday As Date) As Boolean

    Dim dtNextDay   As Date

    existsSubstituteHoliday = False

    If dicHoliday_.Exists(dtDate) = False Then
        'dtDateが祝日でなければ終了
        Exit Function
    End If

    '適用期間のみを対象とする
    If dtDate >= TRANSFER_HOLIDAY1_BEGIN_DATE And dtDate < TRANSFER_HOLIDAY2_BEGIN_DATE Then
        If Weekday(dtDate) = vbSunday Then
            '祝日が日曜日であれば、翌日(月曜日)が振替休日
            dtSubstituteHoliday = DateAdd("d", 1, dtDate)

            existsSubstituteHoliday = True
        End If
    ElseIf dtDate >= TRANSFER_HOLIDAY2_BEGIN_DATE Then
        '「国民の祝日」が日曜日に当たるときは、その日後においてその日に最も近い「国民の祝日」でない日を休日とする
        If Weekday(dtDate) = vbSunday Then
            dtNextDay = DateAdd("d", 1, dtDate)

            '直近の祝日でない日を取得
            Do Until dicHoliday_.Exists(dtNextDay) = False
                dtNextDay = DateAdd("d", 1, dtNextDay)
            Loop

            dtSubstituteHoliday = dtNextDay

            existsSubstituteHoliday = True
        End If
    End If

End Function

'//////////////////////////////////////////////////
'国民の休日の有無
' 祝日(dtDate)に対す国民の休日の有無(ある場合は、dtNationalHolidayに代入される)
'//////////////////////////////////////////////////
Private Function existsNationalHoliday(ByVal dtDate As Date, ByRef dtNationalHoliday As Date) As Boolean

    Dim dtBaseDay   As Date
    Dim dtNextDay   As Date

    existsNationalHoliday = False

    If dicHoliday_.Exists(dtDate) = False Then
        'dtDateが祝日でなければ終了
        Exit Function
    End If

    '適用期間のみを対象とする
    If dtDate >= NATIONAL_HOLIDAY_BEGIN_DATE Then
        dtBaseDay = DateAdd("d", 1, dtDate)

        '直近の祝日でない日を取得
        Do Until dicHoliday_.Exists(dtBaseDay) = False
            dtBaseDay = DateAdd("d", 1, dtBaseDay)
        Loop

        '日曜日であれば対象外
        If Weekday(dtBaseDay) <> vbSunday Then
            dtNextDay = DateAdd("d", 1, dtBaseDay)

            '翌日が祝日であれば対象
            If dicHoliday_.Exists(dtNextDay) = True Then
                existsNationalHoliday = True

                dtNationalHoliday = dtBaseDay
            End If
        End If
    End If

End Function

'//////////////////////////////////////////////////
'月の第N W曜日の日時を取得
'//////////////////////////////////////////////////
Private Function getNthWeeksDayOfWeek(ByVal lYear As Long, _
                                      ByVal lMonth As Long, _
                                      ByVal lNth As Long, _
                                      ByVal lDayOfWeek As VbDayOfWeek) As Date

    Dim dt1stDate       As Date
    Dim lDayOfWeek1st   As Long
    Dim lOffset         As Long

    '指定年月の1日を取得
    dt1stDate = DateSerial(lYear, lMonth, 1)

    '1日の曜日を取得
    lDayOfWeek1st = Weekday(dt1stDate)

    '指定日へのオフセットを取得
    lOffset = lDayOfWeek - lDayOfWeek1st

    If lDayOfWeek1st > lDayOfWeek Then
        lOffset = lOffset + 7
    End If

    lOffset = lOffset + 7 * (lNth - 1)

    getNthWeeksDayOfWeek = DateAdd("d", lOffset, dt1stDate)

End Function

'//////////////////////////////////////////////////
'春分の日を取得
'//////////////////////////////////////////////////
Private Function getVernalEquinoxDay(ByVal lYear As Long) As Date

    Dim lDay    As Long

    lDay = Int(20.8431 + 0.242194 * (lYear - 1980) - Int((lYear - 1980) / 4))

    getVernalEquinoxDay = DateSerial(lYear, 3, lDay)

End Function

'//////////////////////////////////////////////////
'秋分の日を取得
'//////////////////////////////////////////////////
Private Function getAutumnalEquinoxDay(ByVal lYear As Long) As Date

    Dim lDay    As Long

    lDay = Int(23.2488 + 0.242194 * (lYear - 1980) - Int((lYear - 1980) / 4))

    getAutumnalEquinoxDay = DateSerial(lYear, 9, lDay)

End Function

Private Sub qSort(ByRef dtHolidays() As Date, ByVal lLeft As Long, ByVal lRight As Long)

    Dim dtCenter    As Date
    Dim dtTemp      As Date
    Dim i           As Long
    Dim j           As Long

    If lLeft < lRight Then
        dtCenter = dtHolidays((lLeft + lRight) \ 2)

        i = lLeft - 1
        j = lRight + 1

        Do While (True)
            i = i + 1
            Do While (dtHolidays(i) < dtCenter)
                i = i + 1
            Loop

            j = j - 1
            Do While (dtHolidays(j) > dtCenter)
                j = j - 1
            Loop

            If i >= j Then
                Exit Do
            End If

            dtTemp = dtHolidays(i)
            dtHolidays(i) = dtHolidays(j)
            dtHolidays(j) = dtTemp
        Loop

        Call qSort(dtHolidays, lLeft, i - 1)
        Call qSort(dtHolidays, j + 1, lRight)
    End If

End Sub

お約束

掲載したコードの使用については、特に制限は設けません。ご自由にお使い下さい。
改造でも、再配布でもOK。
使用にあたって、私への連絡等は不要です。

ただし、使用した結果、何らかのトラブル、損害、その他諸々の事象が発生しても、私は一切関与しません。
ソースコードを組み込んだ方が責任を取れる範囲内で使って下さい。

バグ、要望、気が付いた事などあれば、コメントしていただければと思います。