[excel][vba]祝日判定 holydaycheck更新

2020年東京オリンピックが、2021年に順延になったことに伴い、特措法で移動になった、海の日, 山の日, オリンピックの日の扱いが決定しました。

2020年は以前の決定通り、2021年は、海の日を開会式の前日に、山の日を閉会式の翌日に、スポーツの日は本来2021年から予定されていた通り、10月第2月曜日に決定した様です。(正確には、2021年は10月11日に移動と言う事らしいですが、10月第2月曜日なので、当初の2021年~の決まりと同様。)

海の日 山の日 スポーツの日
2020年 7月23日 8月10日 7月24日
2021年 7月22日 8月9日 10月11日
2022年以降 7月第3月曜日 8月11日 10月第2月曜日

それに伴い、祝日判定関数holydaycheckを更新しました。更新したのは、祝日の定義部分のみで、ロジックの変更はありません。

使い方は、コメントを参考にして下さい。

一番簡単な使い方は、

=holydaycheck(日付が入っているセル)

です。指定日が、祝日, 振替休日, 国民の休日の場合に1を返し、それ以外(平日, 土曜日, 日曜日)は0を返します。

=holydaycheck(日付が入っているセル,1)

とオプションに1を入れると、祝日, 振替休日, 国民の休日, 日曜日に1を返し、それ以外(平日, 土曜日)は0を返します。

=holydaycheck(日付が入っているセル,2)

とオプションに2を入れると、祝日, 振替休日, 国民の休日, 日曜日に1を、土曜日に2を返し、それ以外(平日)は0を返します。

=holydaycheck(日付が入っているセル,3)

とオプションに3を入れると、指定日が祝日の時、祝日の名称を返し、それ以外は空文字列を返します。

祝日日テーブル』と言うシートを作ると、祝日日の指定を『祝日日テーブル』シートから読み取ります。祝日日の設定の方法は、コメントを参考にしてください。(日付の指定法は、holydaycheck独特の指定法がそのまま利用できます。)
なお、『祝日日テーブル』シートを利用する場合は、A列の書式は必ず文字列に指定して下さい。書式が文字列でないと、正しく認識されません。

holydaycheckの結果が、例えばB1セルに入る時、条件付き書式の『数式を指定して、書式設定するセルを決定』で、『=B1=1』などとすると、holydaycheckの結果に応じて、任意のセルの書式を変更する事ができます。
詳しくは、『数式を指定して、書式設定するセルを決定』の使い方Googleなどで検索して見て下さい。


Option Explicit
' ------------------------------------------------------
'
'   祝日判定
'     IN  : pDay  : 指定日付(シリアル日付)
'           pFlag : 出力結果の指定
'     OUT : 祝日判定の結果 など
'
'     pFlag = 0 の時 (pFlag 省略時)
'       指定日付の祝日判定を行う
'       OUT : 0:平日(土曜日含む) 1:祝日/休日
'     pFlag = 1 の時
'       指定日付の祝日, 日曜日判定を行う
'       OUT : 0:平日(土曜日含む) 1:祝日/休日/日曜日
'     pFlag = 2 の時
'       指定日付の祝日, 日曜日, 土曜日判定を行う
'       OUT : 0:平日 1:祝日/休日/日曜日 2:土曜日
'     pFlag = 3 の時
'       指定日付が祝日/休日の時、その理由を文字列で返す
'       OUT : 平日      : 空文字列を返す
'             祝日      : 祝日テーブルで指定された
'                         祝日名称を返す
'             振替休日  : 『振替休日』と言う文字列を返す
'             国民の休日: 『国民の休日』と言う文字列を返す
'
'     ※祝日テーブルの設定方法は、
'       『祝日日テーブルの定義』を参照。
'
'     ※祝日テーブルの内容を、『祝日日テーブル』シート
'       でも、指定できる様にしました。
'       『祝日日テーブル』シートが定義されている場合には、
'       プログラムの中の、祝日テーブルの内容は無視し、
'       『祝日日テーブル』シートの定義を優先します。
'     ※『祝日日テーブル』シートを作る時に、
'           A列: 日付情報(月/日 or 年/月/日を指定。
'                年 の範囲指定や、
'                月/!, 月/2m の様な指定も可能です。
'           B列: 祝日の名称
'        を指定します。基本的に、祝日日テーブル』と同一
'        フォーマットで指定します。
'     ※A列の表示形式は『文字列』を指定してください。
'       それ以外だと正しく読み込まれません。
'
'   Created by Yasuyuki Imai <waver5516@gmail.com>
'   Licence Affero GPL
'
' ------------------------------------------------------
Public Function holidaycheck(pDay As Variant, _
                             Optional pFlag As Integer = 0)

    ' ========== 変数定義 =============================
    ' ----- 日付の文字列表現
    Dim psYmd As String
    ' ----- 戻り値
    Dim pR As Variant
    ' ----- 処理日付保存用
    Dim holidayDatas As Variant
    ' ==================================================

    ' パラメータの年月日を、yyyy/mm/dd 形式に整形する
    psYmd = Format(Year(pDay), "0000") + "/" + _
            Format(Month(pDay), "00") + "/" + _
            Format(Day(pDay), "00")

    ' 休日テーブルの解析
    holidayDatas = analyzer(pDay, psYmd)

    ' 休日の判定
    pR = decisioner(holidayDatas, pDay, psYmd, pFlag)

    holidaycheck = pR
End Function


' ------------------------------------------------------
' holiday_table
'   祝日テーブルの定義
'    IN  : なし
'    OUT : 祝日テーブル
' ------------------------------------------------------
Private Function holiday_table()

    ' ========== 変数定義 =============================
    Dim holidayTbl As Variant
    ' ==================================================

    ' ---------- 祝日日テーブルの定義: 開始
    '   ---------- 祝日日テーブルのフォーマット解説: 開始
    '   1) 月/日:祝日の名称 または 年/月/日:祝日の名称
    '      で定義する。
    '   2) 日は、
    '      1. 数値(1, 15…)      : 固定の日付
    '      2. 第n週のw曜日(2m…) : 第2週の月曜日なら 2m
    '                              曜日は、s m t w u u f a
    '                              で、日曜日~土曜日を指定する。
    '                              ※曜日指定は、小文字のみ有効。
    '                              例) 1/2m で 1月の第2週目の
    '                                  月曜日の日付を求める。
    '                                  → 成人の日 の日付を求める。
    '      3. 春分/秋分(!)       : 3月, 9月限定で ! を指定すると、
    '                              春分の日, 秋分の日を
    '                               簡易計算で求める
    '   3) 年を指定すると、該当する年のみ祝日とする
    '      年は、
    '      1. yyyy       : 指定の年のみ祝日がある。
    '      2. -yyyyy     : 指定の年まで祝日がある。
    '      3. yyyy-      : 指定の年から祝日がある。
    '      4. yyyy-yyyyy : 指定の年の間のみ祝日がある。
    '      ※ 年を範囲で指定する場合には、指定の年も含まれる。
    '   ---------- 祝日日テーブルのフォーマット解説: 終了
    ' ---------- cf : WikiPedia 『国民の祝日』より
    holidayTbl = Array("1/1:元旦", "-1999/1/15:成人の日", "2000-/1/2m:成人の日", _
                       "2/11:建国記念の日", "2020-/2/23:天皇誕生日", "3/!:春分の日", _
                       "-1988/4/29:天皇誕生日", "1989-2006/4/29:みどりの日", _
                       "2007-/4/29:昭和の日", "2019/5/1:新天皇即位", "5/3:建国記念日", _
                       "2007-/5/4:みどりの日", "5/5:こどもの日", "1996-2002/7/20:海の日", _
                       "2002-2019/7/3m:海の日", "2020/7/23:海の日", "2021/7/22:海の日", "2022-/7/3m:海の日", _
                       "2016-2019/8/11:山の日", "2020/8/10:山の日", "2021/8/9:山の日", "2022-/8/11:山の日", _
                       "1966-2002/9/15:敬老の日", "2003-/9/3m:敬老の日", _
                       "9/!:秋分の日", "1966-1999/10/10:体育の日", "2000-2019/10/2m:体育の日", _
                       "2020/7/24:スポーツの日", "2021-/10/2m:スポーツの日", _
                       "2019/10/22:即位礼正殿の儀", "11/3:文化の日", _
                       "11/23:勤労感謝の日", "1989-2018/12/23:天皇誕生日")
    ' ---------- 祝日日テーブルの定義: 終了

    ' ---------- 祝日日テーブルの解析: 開始

    holiday_table = holidayTbl
End Function


' ------------------------------------------------------
' checksheet
'   指定したシートが存在するか確認する
'    IN  : sSheet : 調べたいシートの名前
'    OUT : 見つかれば True
' ------------------------------------------------------
Private Function checksheet(sSheet As String) As Boolean
    Dim ws As Worksheet, flag As Boolean

    If sSheet <> "" Then
        For Each ws In Worksheets
            If ws.Name = sSheet Then flag = True
        Next ws
    End If
    checksheet = flag
End Function


' ------------------------------------------------------
' loadsheet
'   シート上に指定された、祝日日データを読み込み
'   配列へ入れて戻る
'    IN  : sSheet : 調べたいシートの名前
'    OUT : 読み込んだシートの内容の文字列型配列
' ------------------------------------------------------
Private Function loadsheet(sSheet As String) As Variant
    Dim i As Integer, wk As String, wks() As String

    i = 1
    Do While Worksheets(sSheet).Cells(i, 1).Value <> ""
        wk = Worksheets(sSheet).Cells(i, 1) & ":" & _
             Worksheets(sSheet).Cells(i, 2)
        ReDim Preserve wks(i - 1)
        wks(i - 1) = wk
        i = i + 1
    Loop

    loadsheet = wks()
End Function


' ------------------------------------------------------
' analyzer
'   祝日テーブルを解析する
'    IN  : pDay   : 指定日付(シリアル日付)
'          psYmd  : 指定日付をゼロサプレスした文字列
'    OUT : 祝日テーブルの読み込み結果
' ------------------------------------------------------
Private Function analyzer(pDay As Variant, _
                          psYmd As String)

    ' ========== 変数定義 =============================
    ' ----- 正規表現オブジェクト
    Dim objReg As Object
    Dim objMatches As Object
    Dim objMatches2 As Object
    ' ----- 正規表現用曜日文字列
    Dim sWeekIdx As String
    ' ----- 戻り値
    Dim pR As Variant
    ' ----- 処理日付保存用
    Dim pYear As Integer
    Dim holidayWork As String
    Dim holidayDatas As Variant
    ' ----- 日付の文字列表現
    Dim sYmd As String
    ' ----- 祝日シート解析用
    Dim sSheet As String
    Dim holidayData() As String
    ' ----- 祝日テーブル用
    Dim pbDay As Variant
    Dim holidayTbl() As Variant
    ' ----- 祝日テーブル分析用
    Dim holidayItem As Variant
    Dim holidayName As String
    Dim holidayMD As String
    Dim sYearMode As String
    Dim iYearTbls1 As Integer
    Dim iYearTbls2 As Integer
    Dim holidayMDArray As Variant
    Dim sYearPara As String
    Dim sM As String
    Dim sD As String
    Dim iDayOfWeekCode As Integer
    Dim iYMDcorrect As Integer
    Dim iM As Integer
    Dim iD As Integer
    ' ----- 一般的なインデックスなど
    Dim i As Integer
    ' ----- サブパターン分解用
    Dim sDayOfWeek As String
    ' ==================================================

    ' 正規表現オブジェクトを作成
    Set objReg = CreateObject("VBScript.RegExp")

    ' 曜日インデックス文字列の定義
    sWeekIdx = "smtwufa"

    ' 戻り値を初期化
    pR = 0

    ' パラメータの年月日から、年だけ取り出す
    pYear = Year(pDay)

    ' 祝日日テーブルシートが存在するか?
    sSheet = "祝日日テーブル"
    If checksheet(sSheet) = True Then
        ' 祝日日シート読み込み
        holidayData() = loadsheet(sSheet)
        For i = LBound(holidayData) To UBound(holidayData)
            ReDim Preserve holidayTbl(i)
            holidayTbl(i) = holidayData(i)
        Next i
    Else
        ' 祝日日テーブル読み込み
        holidayTbl = holiday_table
    End If

    ' 祝日テーブルのループ
    For i = LBound(holidayTbl) To UBound(holidayTbl)

        ' 名称部分を取り出すために : で分離
        holidayItem = Split(holidayTbl(i), ":")
        holidayName = holidayItem(1)
        holidayMD = holidayItem(0)

        ' 祝日テーブルを分析し、
        ' 日付タイプと範囲指定用の日付を取得する
        '
        ' 分析結果の初期化
        '   sYearMode : 年指定タイプ
        '                 T : 以降のみ指定されている
        '                 F : 迄のみ指定されている
        '                 R : 範囲が指定されている
        '                 E : 単独で指定されている
        '                 - : パターン違反
        '                 N : 年の指定は無い
        '  iYearTbls1 : 年の1つ目(T/F/R/E で使用)
        '  iYearTbls2 : 年の2つ目(R で使用, その他は0)
        sYearMode = "N"
        iYearTbls1 = 0
        iYearTbls2 = 0

        ' ---------- 抽出条件の取得: 開始
        ' 祝日テーブルから抽出条件を取得する

        ' 開始年/終了年が指定されているか確認する
        holidayMDArray = Split(holidayMD, "/")
        If UBound(holidayMDArray) = 2 Then

            ' 年も指定されている時のチェック, 抽出
            sYearPara = holidayMDArray(0)
            sM = holidayMDArray(1)
            sD = holidayMDArray(2)

            ' 年の前に - が付いて居るか?
            With objReg
                .Pattern = "^\-\d{4}$"
                .IgnoreCase = False
                .Global = False
                .MultiLine = False
            End With
            If objReg.Test(sYearPara) = True Then
                sYearMode = "T"
                iYearTbls1 = CInt(Mid(sYearPara, 2, 4))
                iYearTbls2 = 0
            Else

                ' 年の後ろに - が付いて居るか?
                With objReg
                    .Pattern = "^\d{4}\-$"
                    .IgnoreCase = False
                    .Global = False
                    .MultiLine = False
                End With
                If objReg.Test(sYearPara) = True Then
                    sYearMode = "F"
                    iYearTbls1 = CInt(Mid(sYearPara, 1, 4))
                    iYearTbls2 = 0
                Else

                    ' 範囲で指定されているか?
                    With objReg
                        .Pattern = "^\d{4}\-\d{4}$"
                        .IgnoreCase = False
                        .Global = False
                        .MultiLine = False
                    End With
                    If objReg.Test(sYearPara) = True Then
                        sYearMode = "R"
                        iYearTbls1 = CInt(Mid(sYearPara, 1, 4))
                        iYearTbls2 = CInt(Mid(sYearPara, 6, 4))
                    Else

                        ' 前にも後ろにも - が無い場合
                        With objReg
                            .Pattern = "^\d{4}$"
                            .IgnoreCase = False
                            .Global = False
                            .MultiLine = False
                        End With
                        If objReg.Test(sYearPara) = True Then
                            sYearMode = "E"
                            iYearTbls1 = CInt(sYearPara)
                            iYearTbls2 = 0

                        ' どのパターンでも無い場合には無視する
                        Else
                            sYearMode = "-"
                            iYearTbls1 = 0
                            iYearTbls2 = 0

                        End If
                    End If
                End If
            End If
        ElseIf UBound(holidayMDArray) = 1 Then
            ' 月と日が指定されている時
            sYearMode = "N"
            sM = holidayMDArray(0)
            sD = holidayMDArray(1)
        End If
        ' ---------- 抽出条件の取得: 終了

        ' ---------- 抽出と指定年の祝日日テーブルの作成: 開始

        ' 祝日日テーブルに指定された年が、現在の年の範囲内にあるか?
        If (sYearMode = "N") Or _
           (sYearMode = "T" And pYear <= iYearTbls1) Or _ (sYearMode = "F" And pYear >= iYearTbls1) Or _
           (sYearMode = "R" And (pYear >= iYearTbls1 And _
                                  pYear <= iYearTbls2)) Or _ (sYearMode = "E" And pYear = iYearTbls1) Then ' 範囲内なら処理を続ける ' 『日』部分を取得するためにマッチさせる With objReg .Pattern = "^([1-5])([" & sWeekIdx & "])$" .IgnoreCase = False .Global = False .MultiLine = False End With Set objMatches = objReg.Execute(sD) sDayOfWeek = "" iDayOfWeekCode = 0 iYMDcorrect = 0 ' ---------- iM, iD へ今年の祝日日を数値型で格納: 開始 ' パターンマッチで部分文字列が取得できた場合 If objMatches.Count > 0 Then
                ' 取得した部分文字列をさらに、
                ' 週と曜日記号を分離する
                Set objMatches2 = objMatches(0).SubMatches
                sD = objMatches2(0)
                sDayOfWeek = objMatches2(1)
                iDayOfWeekCode = InStr(sWeekIdx, sDayOfWeek)
                iM = CInt(sM)

                ' 第n週のw曜日を求める
                iD = nnweek(psYmd, sD, iDayOfWeekCode)

            Else
                ' パターンマッチで部分文字列が取得できない場合

                ' 『日』が『!』だった場合
                If sD = "!" Then
                    ' ----- 春分の日, 秋分の日の日付を求める
                    If sM = "3" Then
                        iM = 3
                        iD = Int(20.8431 + 0.242194 _
                           * (pYear - 1980) _
                           - Int((pYear - 1980) / 4))
                    ElseIf sM = "9" Then
                        iM = 9
                        iD = Int(23.2488 + 0.242194 _
                           * (pYear - 1980) _
                           - Int((pYear - 1980) / 4))
                    End If

                ' 『日』が固定日付だった場合
                Else
                    iM = CInt(sM)
                    iD = CInt(sD)
                End If

            End If
            ' ---------- iM, iD へ今年の祝日日を数値型で格納: 終了

            ' 今年の祝日日を『年/月/日』形式にし、配列へ入れる
            ' 祝日日の内容を配列へ入れる
            sYmd = Format(pYear, "0000") + "/" + _
                   Format(iM, "00") + "/" + _
                   Format(iD, "00")
            holidayWork = sYmd & "," & holidayName
            push holidayDatas, holidayWork

        End If
        ' ---------- 抽出と指定年の祝日日テーブルの作成: 終了

    Next
    ' ---------- 祝日日テーブルの解析: 終了

    analyzer = holidayDatas
End Function


' ------------------------------------------------------
' decisioner
'   祝日の判定を行う
'    IN  : holidayDatas : 祝日テーブルの読み込み結果
'          pDay         : 指定日付(シリアル日付)
'          psYmd        : 指定日付をゼロサプレスした文字列
'          pFlag        : 動作フラグ
'    OUT : 祝日テーブルの読み込み結果
' ------------------------------------------------------
Private Function decisioner(holidayDatas As Variant, _
                            pDay As Variant, _
                            psYmd As String, _
                            pFlag As Integer)

    ' ========== 変数定義 =============================
    ' ----- 戻り値
    Dim pR As Variant
    ' ----- 途中経過用
    Dim pRf As Integer
    Dim pRf2 As Integer
    ' ----- 一般的なインデックスなど
    Dim i As Integer
    ' ----- 処理日付保存用
    Dim YmdName As Variant
    Dim holidayYmd As String
    Dim holidayName As String
    ' ----- 祝日テーブル用
    Dim pbDay As Variant
    ' ----- 日付の文字列表現
    Dim pbsYmd As String
    ' ==================================================

    ' 戻り値を初期化
    pR = 0

    ' ---------- 休日の判定: 開始

    ' 祝日なら フラグ(1) または 祝祭日の理由 を返す
    For i = LBound(holidayDatas) To UBound(holidayDatas)
        YmdName = Split(holidayDatas(i), ",")
        holidayYmd = YmdName(0)
        holidayName = YmdName(1)
        If psYmd = holidayYmd Then
            ' pFlag が 3 なら、祝日名を返す、
            ' 0~2 なら、フラグを返す
            If pFlag = 0 Or _
               pFlag = 1 Or _
               pFlag = 2 Then
                pR = 1
            ElseIf pFlag = 3 Then
                pR = holidayName
            End If
        End If
    Next
    ' 以降の処理は祝日は不要なので
    If pR = 0 Then
        ' 当日が日曜日ならループする必要は無い
        If Weekday(pDay) <> 1 Then

            ' 国民の祝日をチェック --------------------------------------
            ' 当日が平日で、前日と翌日が共に祝日なら国民の休日

            ' 前日が祝祭日か調べる
            pRf2 = 0
            pbDay = DateAdd("d", -1, pDay)
            pbsYmd = Format(Year(pbDay), "0000") + "/" + _
                     Format(Month(pbDay), "00") + "/" + _
                     Format(Day(pbDay), "00")
            ' 祝祭日判定
            For i = LBound(holidayDatas) To UBound(holidayDatas)
                YmdName = Split(holidayDatas(i), ",")
                holidayYmd = YmdName(0)
                holidayName = YmdName(1)
                If pbsYmd = holidayYmd Then
                    pRf2 = 1
                End If
            Next
            If pRf2 = 1 Then
                ' 翌日が祝祭日か調べる
                pbDay = DateAdd("d", 1, pDay)
                pbsYmd = Format(Year(pbDay), "0000") + "/" + _
                         Format(Month(pbDay), "00") + "/" + _
                         Format(Day(pbDay), "00")
                ' 祝祭日判定
                pRf2 = 0
                For i = LBound(holidayDatas) To UBound(holidayDatas)
                    YmdName = Split(holidayDatas(i), ",")
                    holidayYmd = YmdName(0)
                    holidayName = YmdName(1)
                    If pbsYmd = holidayYmd Then
                        pRf2 = 1
                    End If
                Next
                If pRf2 = 1 Then
                    ' 前日と翌日が祝祭日なら、国民の休日
                    If pFlag = 0 Or _
                       pFlag = 1 Or _
                       pFlag = 2 Then
                        pR = 1
                    ElseIf pFlag = 3 Then
                        pR = "国民の休日"
                    End If
                End If
            End If
            ' ------------------------------------------

            ' 振替休日をチェック -----------------------
            ' 今日から、前回の日曜日まで戻り、途中に平日が出てくれば、
            ' 振替休日では無い。
            ' 日曜日まで平日が出てこなければ、振替休日

            ' 仮に、振替休日とする
            pRf = 1
            ' 前日から次の日曜日までのループ
            pbDay = pDay
            Do While Weekday(pbDay) > 1
                ' 1日前が祝祭日か調べる
                pbDay = DateAdd("d", -1, pbDay)
                pbsYmd = Format(Year(pbDay), "0000") + "/" + _
                         Format(Month(pbDay), "00") + "/" + _
                         Format(Day(pbDay), "00")
                ' 祝祭日判定
                pRf2 = 0
                For i = LBound(holidayDatas) To UBound(holidayDatas)
                    YmdName = Split(holidayDatas(i), ",")
                    holidayYmd = YmdName(0)
                    holidayName = YmdName(1)
                    If pbsYmd = holidayYmd Then
                        pRf2 = 1
                    End If
                Next
                ' 祝日が見つかったら、振替休日では無い
                If pRf2 = 0 Then
                    pRf = 0
                End If
            Loop
            ' 日曜日まで、平日が一日も無ければ振替休日
            If pRf = 1 Then
                If pFlag = 0 Or _
                   pFlag = 1 Or _
                   pFlag = 2 Then
                    pR = 1
                ElseIf pFlag = 3 Then
                    pR = "振替休日"
                End If
            End If
            ' ------------------------------------------
        End If

        ' pFlag が 3 以外の場合で、pFlag の指定に沿って、
        ' 日曜日, 土曜日の情報を設定する
        If pFlag = 0 Or pFlag = 1 Or pFlag = 2 Then
            ' pFlag に 1 か 2 が指定されている時で、日曜日なら 1 を返す
            If (pFlag = 1 Or pFlag = 2) And _
               (Weekday(pDay) = 1) Then
                pR = 1
            End If
            ' pFlag に 2 が指定されている時で、土曜日なら 2 を返す
            If (pFlag = 2) And (Weekday(pDay) = 7) Then
                pR = 2
            End If
        ElseIf pFlag = 3 And (pR = "" Or pR = 0) Then
            pR = ""
        End If

    End If
    ' ---------- 休日の判定: 終了

    decisioner = pR
End Function


' ------------------------------------------------------
' nnweek
'   指定年月の第n週のw曜日の日付を取得する
'   週の単位は、指定年月1日の曜日~指定年月6日までが第1週目
'    IN  : pDay   : 指定日付(シリアル日付)
'          pWeekd : 週番号
'          pDweek : 曜日コード(1:日曜日 2:月曜日…)
'    OUT : 該当日付(非シリアル日付)
' ------------------------------------------------------
Private Function nnweek(pDay As Variant, _
                        pWeekn As Variant, _
                        pDweek As Variant)
    Dim a As Integer
    Dim m As Integer
    Dim o As Integer
    Dim r As Integer

    ' 指定の年/月/1の曜日を取得
    a = Weekday(DateSerial(Year(pDay), Month(pDay), 1))
    ' 求めたい曜日(日曜日は1, 土曜日は7)と、1日の差を求める
    m = pDweek - a
    ' マイナスに成った場合には、補正
    If m < 0 Then
        m = m + 7
    End If
    ' 求めたい週の先頭の日付を求める(第1週なら1, 第3週なら21)
    o = (pWeekn - 1) * 7 + 1
    ' 週の先頭日付と、求めた差を足し、
    ' 第n週の指定曜日(日曜日は1, 土曜日は7)の日付を求める
    r = o + m

    nnweek = r
End Function


' ------------------------------------------------------
' getweekno
'   指定日付の週番号を取得
'    IN  : pDay   : 指定日付(シリアル日付)
'        : pMode  : 週単位の切り替え(省略時は 0 と見なす。)
'                     0: 1日の曜日に関係なく、
'                        日曜日~土曜日の単位で週を求める。
'                     1: 1日~7日が第1週, …
'    OUT : 週番号
' ------------------------------------------------------
Public Function getweekno(pDay As Variant, _
                          Optional pMode As Integer = 0)
    Dim r As Integer

    If pMode = 0 Then
        r = Int((Day(pDay) - Weekday(pDay) + 7) / 7) + 1
    ElseIf pMode = 1 Then
        r = Int((Day(pDay) - 1) / 7) + 1
    End If

    getweekno = r
End Function


' ------------------------------------------------------
' getlastday
'   指定年月の日数を求める
'    IN  : pDay : 指定日付(シリアル日付)
'    OUT : 指定年月の日数(Integer)
' ------------------------------------------------------
Public Function getlastday(pDay As Variant)
    Dim ms As Long
    Dim nms As Long
    Dim r As Integer

    ' 今月1日をシリアル日付で取得
    ms = DateSerial(Year(pDay), Month(pDay), 1)

    ' 来月1日をシリアル日付で取得
    nms = DateAdd("m", 1, ms)

    ' 今月の日数
    r = nms - ms

    getlastday = r
End Function


' ------------------------------------------------------
' calcwncalendar
'   指定年月, 指定週, 指定曜日の日付を取得する
'     週番号と曜日コードから、一般的なカレンダーの日付を
'     割り出す
'     指定年月の範囲外に成った場合には、前月/翌月の
'     日付を返す
'    IN  : pDay  : 指定年月(シリアル日付)
'          pWho  : 週番号(1日の曜日に関係なく、
'                  指定年月の1日が存在する週の
'                  日曜日~土曜日が第1週目)
'          pWeek : 曜日コード(1:日曜日 2:月曜日…)
'    OUT : 指定日をシリアル日付で返す
' ------------------------------------------------------
Public Function calcwncalendar(pDay As Variant, pWno As Variant, pWeek As Variant)
    Dim nm1 As Long
    Dim nw1 As Integer
    Dim dmax As Integer
    Dim cor As Integer
    Dim cday As Integer
    Dim wk As Long
    Dim r As Variant

    ' 今月1日の日付
    nm1 = DateSerial(Year(pDay), Month(pDay), 1)

    ' 今月1日の曜日
    nw1 = Weekday(nm1)

    ' 今月の日数
    dmax = getlastday(pDay)

    ' 日曜日への補正値
    cor = Day(nm1) - nw1

    ' 指定年月, 指定週, 指定曜日の日付
    cday = (pWno - 1) * 7 + cor + pWeek

    ' 結果格納
    r = DateSerial(Year(pDay), Month(pDay), cday)

    ' アンダーとオーバーの補正
    ' アンダー?
    If cday <= 0 Then ' 今日を除くために cday = cday - 1 ' アンダー時の補正値 r = DateAdd("d", cday, nm1) ' オーバー? ElseIf cday > dmax Then
        ' 来月1日のシリアル日付
        wk = DateAdd("m", 1, nm1)

        ' オーバー時の補正値
        r = DateSerial(Year(wk), Month(wk), cday - dmax)
    End If

    calcwncalendar = r
End Function


' ------------------------------------------------------
' push
'   VBScript/VBA でまともに動作するpush
'     IN  : arr : 動的配列
'           elm : pushしたい内容(オブジェクトも可!!)
'     OUT : なし
'
'   出典 :
'     http://www.songmu.jp/riji/archives/2008/07/vbscriptpush.html
'     おそらくはそれさえも平凡な日々 - VBScriptにおけるpushの決定版
' ------------------------------------------------------
Private Sub push(arr, elm)
    Dim i, tmp: i = 0

    If IsArray(arr) Then
        For Each tmp In arr
            i = 1
            Exit For
        Next
        If i = 1 Then
            ReDim Preserve arr(UBound(arr) + 1)
        Else
            ReDim arr(0)
        End If
    Else
        arr = Array(0)
    End If

    If IsObject(elm) Then
        Set arr(UBound(arr)) = elm
    Else
        arr(UBound(arr)) = elm
    End If

End Sub


' ------------------------------------------------------
'   Registerholidaycheck : 関数の登録
' ------------------------------------------------------
Sub Registerholidaycheck()
    Application.MacroOptions Macro:="holidaycheck", _
    Description:="祝日日の判定を行います。", _
    Category:="日付/時刻", _
    ArgumentDescriptions:=Array("引数 1 : 指定日(シリアル日付)", "引数 2 : 出力結果(数値 0:平日,祝日/休日の判定 1: 平日/土曜日,祝日/休日の判定  2: 平日, 日曜日/祝日/休日, 土曜日の判定  引数 3: 祝祭日の理由(文字列))")
End Sub


' ------------------------------------------------------
'   Registegetweekno : 関数の登録
' ------------------------------------------------------
Sub Registegetweekno()
    Application.MacroOptions Macro:="getweekno", _
    Description:="指定日が何周目なのかを返します。", _
    Category:="日付/時刻", _
    ArgumentDescriptions:=Array("引数 1 : 指定日(シリアル日付)", "引数 2 : 動作モード(数値: 0: 1日の曜日に関係なく、日曜日~土曜日の単位で曜日番号を求めます。 1: 週が跨ったも、1日~7日必ず、1週目として週番号を求めます。)")
End Sub


' ------------------------------------------------------
'   Registegetlastday : 関数の登録
' ------------------------------------------------------
Sub Registegetlastday()
    Application.MacroOptions Macro:="getlastday", _
    Description:="指定年月の最終日の日付を返します。", _
    Category:="日付/時刻", _
    ArgumentDescriptions:=Array("引数 1 : 指定年月(シリアル日付)")
End Sub


' ------------------------------------------------------
'   Registercalcwncalendar : 関数の登録
' ------------------------------------------------------
Sub Registercalcwncalendar()
    Application.MacroOptions Macro:="calcwncalendar", _
    Description:="基準日, 週番号, 曜日番号より一般的なカレンダーを計算し、シリアル日付で返します。", _
    Category:="日付/時刻", _
    ArgumentDescriptions:=Array("引数 1 : 基準年月(シリアル日付)", "引数 2 : 週番号(数値 第1週目: 1. 第2週目: 2…)", "引数 3 : 曜日番号 : 曜日(数値 日曜日: 0, 月曜日: 1 … 金曜日: 5, 土曜日: 6)")
End Sub


シェアする

  • このエントリーをはてなブックマークに追加

フォローする