Excel VBA で祝日一覧を出力

まだちょっと不便なところがある……というか、貼り付けてそのまま関数書けば実行できるということろまではいけなかったんだけども。
一応、ActiveX のボタン（フォームコントロールのボタンでは呼び出せなかった）もしくは、メニューに項目を追加して、そこで関数名で呼び出せばなんとかリスト出力まではできるようになったので、残しておく。

2019年、2020年の、なんとイレギュラーなことか。

いちおう、2030年までは、他のサイトの情報と照らし合わせて正確に出力していることを確認済み。
この1～2年のようなイレギュラーがなければ、問題なく動いてくれるだろう。

これで、この関数は
・休日・祝日判定
・第ｘ週目の月曜日を出力
・祝日リスト出力

という、なんとも気の抜けそうな機能を充実させることに成功した！

Option Explicit

' セル位置関係
Dim aRow            As Long
Dim aCol            As Long
Dim wi              As Long

Function getHolidayList()
' #########################################################################
' # 西暦を入れるとアクティブセルから下に祝日一覧を入れるマクロ
' # セルに関数名を入れた使い方はできないので、改造中。
' # ActiveX コントロールのボタン、もしくはメニューバーから呼び出すこと。
' #########################################################################

Dim msgInputYear    As String
Dim msgOverRideChk  As String

Dim pInputYear      As Variant

Dim chk             As Variant
Dim tmp             As Variant

msgInputYear = "出力したい西暦を入力してください。"
msgOverRideChk = "現在のアクティブセルから下に2列、リストを出力します。" & vbCrLf & "（既存の情報は上書き）"

wi = 1

pInputYear = InputBox(msgInputYear, "西暦", Year(Now))
Select Case VarType(pInputYear)
    ' Empty値 (0)
    Case vbEmpty
        Exit Function
    
    ' 文字列型 (8)
    Case vbString
        pInputYear = StrConv(pInputYear, vbNarrow)
    
    Case Else
        MsgBox "Error"

End Select

If IsNumeric(pInputYear) = False Then
    'MsgBox "数字を入力してください", vbOKOnly, "Error"
    Exit Function
End If

If MsgBox(msgOverRideChk, vbYesNo) Then
    ' アクティブセルの位置を取得
    aRow = ActiveCell.Row
    aCol = ActiveCell.Column

    Cells(aRow, aCol) = pInputYear & "年"
    Cells(aRow, aCol + 1) = "祝日"
    
    '元日 1月1日
    tmp = DateValue(pInputYear & "/1/1")
    chk = wDD(tmp, "元日")
    If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")
    
    '成人の日 1月の第2月曜日
    chk = wDD(NumWeek(pInputYear, 1, 2), "成人の日")
    
    '建国記念の日 政令で定める日(2/11)
    tmp = DateValue(pInputYear & "/2/11")
    chk = wDD(tmp, "建国記念の日")
    If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")
    
    '天皇誕生日 12月23日 → 2月23日（2019年 天皇の即位に伴う変更）
    If 2019 < pInputYear Then
        chk = wDD(DateValue(pInputYear & "/2/23"), "天皇誕生日")
        If Weekday(DateValue(pInputYear & "/2/24")) = vbMonday Then chk = wDD(DateValue(pInputYear & "/2/24"), "振替休日")
    End If
    
    '春分の日
    tmp = DateValue(pInputYear & "/3/" & Int(20.8431 + 0.242194 * (pInputYear - 1980) - Int((pInputYear - 1980) / 4)))
    chk = wDD(tmp, "春分の日")
    If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")

    '昭和の日 4月29日
    tmp = DateValue(pInputYear & "/4/29")
    chk = wDD(tmp, "昭和の日")
    If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")
    
    '天皇の即位の日 2019年5月1日
    If pInputYear = 2019 Then
        chk = wDD(DateValue("2019/4/30"), "国民の休日")
        chk = wDD(DateValue("2019/5/1"), "天皇の即位の日")
        chk = wDD(DateValue("2019/5/2"), "国民の休日")
    End If

    '憲法記念日 5月3日
    chk = wDD(DateValue(pInputYear & "/5/3"), "憲法記念日")
    
    'みどりの日 5月4日
    chk = wDD(DateValue(pInputYear & "/5/4"), "みどりの日")
    
    'こどもの日 5月5日
    tmp = DateValue(pInputYear & "/5/5")
    chk = wDD(tmp, "こどもの日")
    
        ' 5月5日が日曜～火曜日だったら、振替休日確定
        If vbSunday <= Weekday(tmp) And Weekday(tmp) <= vbTuesday Then
            chk = wDD(tmp + 1, "振替休日")
        End If

    '海の日 7月の第3月曜日
    If pInputYear = 2020 Then
        chk = wDD(DateValue("2020/7/23"), "海の日")
        chk = wDD(DateValue("2020/7/24"), "スポーツの日")
    Else
        tmp = NumWeek(pInputYear, 7, 3)
        chk = wDD(tmp, "海の日")
        If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")
    End If
    
    '山の日 8月11日
    If pInputYear = 2020 Then
        chk = wDD(DateValue("2020/8/10"), "山の日")
    Else
        tmp = DateValue(pInputYear & "/8/11")
        chk = wDD(tmp, "山の日")
        If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")
    End If

    '敬老の日 9月の第3月曜日
    chk = wDD(NumWeek(pInputYear, 9, 3), "敬老の日")
    
    '国民の休日 祝日に挟まれた平日
    tmp = DateValue(pInputYear & "/9/" & Int(23.2488 + 0.242194 * (pInputYear - 1980) - Int((pInputYear - 1980) / 4)))
    'If Weekday(tmp) = vbWednesday Then chk = wDD(tmp - 1, "国民の休日")
    If tmp - 2 = NumWeek(pInputYear, 9, 3) Then chk = wDD(tmp - 1, "国民の休日")
    
    '秋分の日
    'tmp = DateValue(pInputYear & "/9/" & Int(23.2488 + 0.242194 * (pInputYear - 1980) - Int((pInputYear - 1980) / 4)))
    chk = wDD(DateValue(tmp), "秋分の日")
    If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")

    '体育の日 10月の第2月曜日 (2020年からスポーツの日に名称変更)
    If pInputYear < 2020 Then
        chk = wDD(NumWeek(pInputYear, 10, 2), "体育の日")
    Else
        If pInputYear <> 2020 Then chk = wDD(NumWeek(pInputYear, 10, 2), "スポーツの日")
    End If

    '即位礼正殿の儀の行われる日 2019年10月22日
    If pInputYear = 2019 Then chk = wDD(DateValue("2019/10/22"), "即位礼正殿の儀の行われる日")

    '文化の日 11月3日
    tmp = DateValue(pInputYear & "/11/3")
    chk = wDD(tmp, "文化の日")
    If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")
    
    '勤労感謝の日 11月23日
    tmp = DateValue(pInputYear & "/11/23")
    chk = wDD(tmp, "勤労感謝の日")
    If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")
    
    '天皇誕生日 12月23日 → 2月23日（2019年 天皇の即位に伴う変更）
    If pInputYear < 2019 Then
        tmp = DateValue(pInputYear & "/12/23")
        chk = wDD(tmp, "天皇誕生日")
        If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")
    End If

End If


End Function

Public Function wDD(Serial, HolidayName)

' Write Date Data
Cells(aRow + wi, aCol) = Serial
Cells(aRow + wi, aCol + 1) = HolidayName

wi = wi + 1

End Function

Public Function chkWorkDay(Optional Serial As Date)
' #########################################################################
' # 呼び出されると、翌営業日を返すマクロ
' # 2020/3/11 初版作成
' #########################################################################

' ### 変数 ################################################################

Dim chkDate As Date
Dim fDate   As Integer

If Serial > 0 Then
    chkDate = Serial
Else
    chkDate = Date
End If

fDate = 1

' ### メイン ##############################################################

Do While fDate > 0
    chkDate = chkDate + 1
    fDate = chkHoliday(chkDate)
Loop

' ### 終了処理 ############################################################

chkWorkDay = chkDate

End Function


Public Function chkHoliday(Serial, Optional RVFlag As Byte = 0)
' #########################################################################
' # 呼び出されると、引数のSerialから休日/祝日判定フラグを返すマクロ
' # 更新履歴
' # 2019/12/5 2020年の特殊な祝日情報に対応した。
' # 2020/3/11 土日を休日と返すようにした。
' #########################################################################

' 戻り値の定義
' 0 = 平日
' 1 = 日曜日(vbSunday)
' 7 = 土曜日(vbSaturday)
' 8 = 祝日

' 変数の宣言
Dim RV As Byte
Dim DayName As String
Dim YYYY As Integer
Dim fSubstitute As Boolean ' 振替休日フラグ

' ### メイン ##############################################################

DayName = "平日"
YYYY = Year(Serial)

' ## 祝日判定 #####
'元日 1月1日
'成人の日 1月の第2月曜日
'建国記念の日 政令で定める日(2/11)
'春分の日 春分の日
'昭和の日 4月29日
'憲法記念日 5月3日
'みどりの日 5月4日
'こどもの日 5月5日
'海の日 7月の第3月曜日
'山の日 8月11日
'敬老の日 9月の第3月曜日
'秋分の日 秋分の日
'体育の日 10月の第2月曜日 (2020年からスポーツの日に名称変更)
'文化の日 11月3日
'勤労感謝の日 11月23日
'天皇誕生日 12月23日 → 2月23日（2019年 天皇の即位に伴う変更）
'国民の休日 祝日に挟まれた平日
'天皇の即位の日及び即位礼正殿の儀の行われる日を休日とする法律 2019年5月1日と2019年10月22日


' 規定の日付
Select Case Serial
  Case DateValue(YYYY & "/1/1")
    DayName = "元旦"
  Case DateValue(YYYY & "/1/2")
    DayName = "年始"
  Case DateValue(YYYY & "/1/3")
    DayName = "年始"
  Case NumWeek(YYYY, 1, 2)
    DayName = "成人の日"
  Case DateValue(YYYY & "/2/11")
    DayName = "建国記念の日"
  Case DateValue(YYYY & "/2/23")
    If 2019 < YYYY Then
      DayName = "天皇誕生日"
    End If
  Case DateValue(YYYY & "/3/" & Int(20.8431 + 0.242194 * (YYYY - 1980) - Int((YYYY - 1980) / 4)))
    ' 参考URL http://www.wanichan.com/pc/excel/2010/5/page07.html
    DayName = "春分の日"
  Case DateValue(YYYY & "/4/29")
    DayName = "昭和の日"
  Case DateValue("2019/4/30")
    DayName = "国民の休日"
  Case DateValue("2019/5/1")
    DayName = "天皇の即位の日"
  Case DateValue("2019/5/2")
    DayName = "国民の休日"
  Case DateValue(YYYY & "/5/3")
    DayName = "憲法記念日"
  Case DateValue(YYYY & "/5/4")
    DayName = "みどりの日"
  Case DateValue(YYYY & "/5/5")
    DayName = "こどもの日"
  Case NumWeek(YYYY, 7, 3)
    DayName = "海の日"
  Case DateValue(YYYY & "/8/11")
    DayName = "山の日"
  Case NumWeek(YYYY, 9, 3)
    DayName = "敬老の日"
  Case NumWeek(YYYY, 9, 3) + 1
    If DateValue(YYYY & "/9/" & Int(23.2488 + 0.242194 * (YYYY - 1980) - Int((YYYY - 1980) / 4))) = NumWeek(YYYY, 9, 3) + 2 Then
      DayName = "国民の休日"
    End If
  Case DateValue(YYYY & "/9/" & Int(23.2488 + 0.242194 * (YYYY - 1980) - Int((YYYY - 1980) / 4)))
    ' 参考URL http://www.wanichan.com/pc/excel/2010/5/page07.html
    DayName = "秋分の日"
  Case NumWeek(YYYY, 10, 2)
    If YYYY <= 2019 Then
      DayName = "体育の日"
    Else
      DayName = "スポーツの日"
    End If
  Case DateValue("2019/10/22")
    DayName = "即位礼正殿の儀の行われる日"
  Case DateValue(YYYY & "/11/3")
    DayName = "文化の日"
  Case DateValue(YYYY & "/11/23")
    DayName = "勤労感謝の日"
  Case DateValue(YYYY & "/12/23")
    If YYYY < 2019 Then
      DayName = "天皇誕生日"
    End If
  Case DateValue(YYYY & "/12/31")
    DayName = "年末"
End Select

' 振替休日
' 「国民の祝日」が日曜日に当たるときは、その日後においてその日に最も近い「国民の祝日」でない日を休日とする
' なので「国民の祝日」の翌日が月曜日だったときも、振替休日となる
Select Case Serial
  Case DateValue(YYYY & "/1/1") + 1
    If Weekday(Serial) = vbMonday Then fSubstitute = True
  Case DateValue(YYYY & "/2/11") + 1
    If Weekday(Serial) = vbMonday Then fSubstitute = True
  Case DateValue(YYYY & "/2/23") + 1
    If YYYY > 2019 And Weekday(Serial) = vbMonday Then fSubstitute = True
  Case DateValue(YYYY & "/3/" & Int(20.8431 + 0.242194 * (YYYY - 1980) - Int((YYYY - 1980) / 4))) + 1
    If Weekday(Serial) = vbMonday Then fSubstitute = True
  Case DateValue(YYYY & "/4/29") + 1
    If Weekday(Serial) = vbMonday Then fSubstitute = True
  Case DateValue(YYYY & "/5/5") + 1
    ' 5月5日が日曜～火曜日だったら、振替休日確定
    If vbSunday <= Weekday(DateValue(YYYY & "/5/5")) And Weekday(DateValue(YYYY & "/5/5")) <= vbTuesday Then fSubstitute = True
  Case DateValue(YYYY & "/9/" & Int(23.2488 + 0.242194 * (YYYY - 1980) - Int((YYYY - 1980) / 4))) + 1
    If Weekday(Serial) = vbMonday Then fSubstitute = True
  Case DateValue(YYYY & "/11/3") + 1
    If Weekday(Serial) = vbMonday Then fSubstitute = True
  Case DateValue(YYYY & "/11/23") + 1
    If Weekday(Serial) = vbMonday Then fSubstitute = True
  Case DateValue(YYYY & "/12/23") + 1
    If YYYY < 2019 And Weekday(Serial) = vbMonday Then fSubstitute = True
End Select
If fSubstitute = True Then
  DayName = "振替休日"
End If

' 2020年特殊対応
Select Case Serial
  Case DateValue("2020/7/20")
    DayName = "平日"
  Case NumWeek(2020, 10, 2)
    DayName = "平日"
  Case DateValue("2020/8/11")
    DayName = "平日"
  Case DateValue("2020/7/23")
    DayName = "海の日"
  Case DateValue("2020/7/24")
    DayName = "スポーツの日"
  Case DateValue("2020/8/10")
    DayName = "山の日"
  Case DateValue("2020/9/22")
    DayName = "秋分の日"
End Select

' 祝日値判定
If DayName = "平日" Then
  ' ## 曜日選択 #####
  If IsDate(Serial) Then
  Select Case Weekday(Serial)
  Case vbSunday
    RV = vbSunday
    DayName = "休日"
  'Case vbMonday
  ' RV = vbMonday
  'Case vbTuesday
  ' RV = vbTuesday
  'Case vbWednesday
  ' RV = vbWednesday
  'Case vbThursday
  ' RV = vbThursday
  'Case vbFriday
  ' RV = vbFriday
  Case vbSaturday
    RV = vbSaturday
    DayName = "休日"
  End Select

  'RV = Weekday(Serial)
  Else
    Exit Function
  End If
Else
  RV = 8
End If

' ### 終了処理 ############################################################

Select Case RVFlag
  Case 0
    chkHoliday = RV
  Case 1
    chkHoliday = DayName
End Select

End Function

Public Function NumWeek(Year, Month, Weeks)
' 参考資料
' http://www.relief.jp/itnote/archives/003241.php

Dim MonNum As Byte
Dim FirstMonDay As Date

' 第1週目の月曜日を求める
Select Case Weekday(DateValue(Year & "/" & Month & "/1"))
  Case vbSunday ' 1
    MonNum = 1
  Case vbMonday ' 2
    MonNum = 0
  Case vbTuesday ' 3
    MonNum = 6
  Case vbWednesday ' 4
    MonNum = 5
  Case vbThursday ' 5
    MonNum = 4
  Case vbFriday ' 6
    MonNum = 3
  Case vbSaturday ' 7
    MonNum = 2
End Select
FirstMonDay = DateValue(Year & "/" & Month & "/" & 1 + MonNum)

' 第1週目月曜日から何週間後なのか、シリアル値を出力
NumWeek = DateValue(Year & "/" & Month & "/" & 1 + MonNum) + 7 * (Weeks - 1)

End Function