Option Explicit

' 祝日シートB1に年を入力 → ボタンで実行
Public Sub FetchHolidays()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("祝日")
    
    Dim y As Long
    y = CLng(ws.Range("B1").Value)
    If y < 1949 Or y > 2099 Then
        MsgBox "Year is out of range (1949-2099).", vbExclamation, "Error"
        Exit Sub
    End If
    
    Dim hol As Collection
    Set hol = BuildJapaneseHolidays(y)
    
    ws.Range("A2:A1000").ClearContents
    Dim i As Long
    For i = 1 To hol.Count
        ws.Range("A" & (i + 1)).Value = hol(i)
    Next i
    ws.Range("A2:A" & (hol.Count + 1)).NumberFormatLocal = "yyyy/mm/dd"
    
    MsgBox CStr(y) & "年の祝日を更新しました (" & hol.Count & "日)", vbInformation, "更新完了"
End Sub

' 指定年の祝日リストを作成
Private Function BuildJapaneseHolidays(ByVal Y As Long) As Collection
    Dim c As New Collection

    ' 固定日
    AddUnique c, DateSerial(Y, 1, 1)   ' 元日
    AddUnique c, DateSerial(Y, 2, 11)  ' 建国記念の日
    If Y >= 2020 Then AddUnique c, DateSerial(Y, 2, 23) ' 天皇誕生日
    AddUnique c, DateSerial(Y, 4, 29)  ' 昭和の日
    AddUnique c, DateSerial(Y, 5, 3)   ' 憲法記念日
    AddUnique c, DateSerial(Y, 5, 4)   ' みどりの日
    AddUnique c, DateSerial(Y, 5, 5)   ' こどもの日
    AddUnique c, DateSerial(Y, 8, 11)  ' 山の日
    AddUnique c, DateSerial(Y, 11, 3)  ' 文化の日
    AddUnique c, DateSerial(Y, 11, 23) ' 勤労感謝の日

    ' ハッピーマンデー
    AddUnique c, NthWeekday(Y, 1, vbMonday, 2)   ' 成人の日
    AddUnique c, NthWeekday(Y, 7, vbMonday, 3)   ' 海の日
    AddUnique c, NthWeekday(Y, 9, vbMonday, 3)   ' 敬老の日
    AddUnique c, NthWeekday(Y, 10, vbMonday, 2)  ' スポーツの日

    ' 春分・秋分
    AddUnique c, DateSerial(Y, 3, VernalDay(Y))
    AddUnique c, DateSerial(Y, 9, AutumnDay(Y))

    ' 振替休日・国民の休日
    AddSubstituteHolidays c
    AddCitizensHoliday c

    SortCollection c
    Set BuildJapaneseHolidays = c
End Function

' 月内の第N・曜日を返す
Private Function NthWeekday(ByVal Y As Long, ByVal M As Long, ByVal FirstWeekday As VbDayOfWeek, ByVal N As Long) As Date
    Dim d As Date
    d = DateSerial(Y, M, 1)
    Do While Weekday(d, vbMonday) <> (FirstWeekday - 0)
        d = d + 1
    Loop
    NthWeekday = d + (N - 1) * 7
End Function

' 春分日（近似）
Private Function VernalDay(ByVal Y As Long) As Integer
    VernalDay = Int(20.8431 + 0.242194 * (Y - 1980)) - Int((Y - 1980) / 4)
End Function

' 秋分日（近似）
Private Function AutumnDay(ByVal Y As Long) As Integer
    AutumnDay = Int(23.2488 + 0.242194 * (Y - 1980)) - Int((Y - 1980) / 4)
End Function

' コレクションに重複なく追加
Private Sub AddUnique(ByRef c As Collection, ByVal d As Date)
    On Error Resume Next
    c.Add d, Format$(d, "yyyy-mm-dd")
    On Error GoTo 0
End Sub

' 振替休日
Private Sub AddSubstituteHolidays(ByRef c As Collection)
    Dim i As Long
    Dim arr() As Date
    arr = ToArray(c)
    For i = LBound(arr) To UBound(arr)
        If Weekday(arr(i), vbSunday) = vbSunday Then
            Dim dd As Date: dd = arr(i) + 1
            Do While IsHoliday(c, dd)
                dd = dd + 1
            Loop
            AddUnique c, dd
        End If
    Next i
End Sub

' 国民の休日
Private Sub AddCitizensHoliday(ByRef c As Collection)
    Dim i As Long
    Dim arr() As Date
    arr = ToArray(c)
    For i = LBound(arr) To UBound(arr) - 1
        Dim mid As Date: mid = arr(i) + 1
        If mid = arr(i + 1) - 1 Then
            If Weekday(mid, vbMonday) <= 5 Then
                AddUnique c, mid
            End If
        End If
    Next i
End Sub

Private Function IsHoliday(ByRef c As Collection, ByVal d As Date) As Boolean
    On Error Resume Next
    Dim tmp As Date: tmp = c(Format$(d, "yyyy-mm-dd"))
    IsHoliday = (Err.Number = 0)
    Err.Clear
    On Error GoTo 0
End Function

' 昇順ソート
Private Sub SortCollection(ByRef c As Collection)
    Dim arr() As Date: arr = ToArray(c)
    Dim i As Long, j As Long, t As Date
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(j) < arr(i) Then
                t = arr(i): arr(i) = arr(j): arr(j) = t
            End If
        Next j
    Next i
    Dim c2 As New Collection
    For i = LBound(arr) To UBound(arr)
        AddUnique c2, arr(i)
    Next i
    Set c = c2
End Sub

' Collection → 配列
Private Function ToArray(ByRef c As Collection) As Date()
    Dim arr() As Date
    ReDim arr(1 To c.Count)
    Dim i As Long
    For i = 1 To c.Count
        arr(i) = c(i)
    Next i
    ToArray = arr
End Function