まだちょっと不便なところがある……というか、貼り付けてそのまま関数書けば実行できるということろまではいけなかったんだけども。
一応、ActiveX のボタン(フォームコントロールのボタンでは呼び出せなかった)もしくは、メニューに項目を追加して、そこで関数名で呼び出せばなんとかリスト出力まではできるようになったので、残しておく。
2019年、2020年の、なんとイレギュラーなことか。
いちおう、2030年までは、他のサイトの情報と照らし合わせて正確に出力していることを確認済み。
この1~2年のようなイレギュラーがなければ、問題なく動いてくれるだろう。
これで、この関数は
・休日・祝日判定
・第x週目の月曜日を出力
・祝日リスト出力
という、なんとも気の抜けそうな機能を充実させることに成功した!
Option Explicit
Dim aRow As Long
Dim aCol As Long
Dim wi As Long
Function getHolidayList()
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)
Case vbEmpty
Exit Function
Case vbString
pInputYear = StrConv(pInputYear, vbNarrow)
Case Else
MsgBox "Error"
End Select
If IsNumeric(pInputYear) = False Then
Exit Function
End If
If MsgBox(msgOverRideChk, vbYesNo) Then
aRow = ActiveCell.Row
aCol = ActiveCell.Column
Cells(aRow, aCol) = pInputYear & "年"
Cells(aRow, aCol + 1) = "祝日"
tmp = DateValue(pInputYear & "/1/1")
chk = wDD(tmp, "元日")
If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")
chk = wDD(NumWeek(pInputYear, 1, 2), "成人の日")
tmp = DateValue(pInputYear & "/2/11")
chk = wDD(tmp, "建国記念の日")
If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")
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, "振替休日")
tmp = DateValue(pInputYear & "/4/29")
chk = wDD(tmp, "昭和の日")
If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 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
chk = wDD(DateValue(pInputYear & "/5/3"), "憲法記念日")
chk = wDD(DateValue(pInputYear & "/5/4"), "みどりの日")
tmp = DateValue(pInputYear & "/5/5")
chk = wDD(tmp, "こどもの日")
If vbSunday <= Weekday(tmp) And Weekday(tmp) <= vbTuesday Then
chk = wDD(tmp + 1, "振替休日")
End If
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
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
chk = wDD(NumWeek(pInputYear, 9, 3), "敬老の日")
tmp = DateValue(pInputYear & "/9/" & Int(23.2488 + 0.242194 * (pInputYear - 1980) - Int((pInputYear - 1980) / 4)))
If tmp - 2 = NumWeek(pInputYear, 9, 3) Then chk = wDD(tmp - 1, "国民の休日")
chk = wDD(DateValue(tmp), "秋分の日")
If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")
If pInputYear < 2020 Then
chk = wDD(NumWeek(pInputYear, 10, 2), "体育の日")
Else
If pInputYear <> 2020 Then chk = wDD(NumWeek(pInputYear, 10, 2), "スポーツの日")
End If
If pInputYear = 2019 Then chk = wDD(DateValue("2019/10/22"), "即位礼正殿の儀の行われる日")
tmp = DateValue(pInputYear & "/11/3")
chk = wDD(tmp, "文化の日")
If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")
tmp = DateValue(pInputYear & "/11/23")
chk = wDD(tmp, "勤労感謝の日")
If Weekday(tmp + 1) = vbMonday Then chk = wDD(tmp + 1, "振替休日")
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)
Cells(aRow + wi, aCol) = Serial
Cells(aRow + wi, aCol + 1) = HolidayName
wi = wi + 1
End Function
Public Function chkWorkDay(Optional Serial As Date)
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)
Dim RV As Byte
Dim DayName As String
Dim YYYY As Integer
Dim fSubstitute As Boolean
DayName = "平日"
YYYY = Year(Serial)
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)))
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)))
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
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
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 vbSaturday
RV = vbSaturday
DayName = "休日"
End Select
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)
Dim MonNum As Byte
Dim FirstMonDay As Date
Select Case Weekday(DateValue(Year & "/" & Month & "/1"))
Case vbSunday
MonNum = 1
Case vbMonday
MonNum = 0
Case vbTuesday
MonNum = 6
Case vbWednesday
MonNum = 5
Case vbThursday
MonNum = 4
Case vbFriday
MonNum = 3
Case vbSaturday
MonNum = 2
End Select
FirstMonDay = DateValue(Year & "/" & Month & "/" & 1 + MonNum)
NumWeek = DateValue(Year & "/" & Month & "/" & 1 + MonNum) + 7 * (Weeks - 1)
End Function