Option Explicit

Sub 月間開催スケジュール取得ループ()
    Dim r As Long
    Dim i As Long

    'For i = 2016 To 2025
    'Range("K6").Value = i

    For r = 1 To 12
        Range("K8").value = r
        Call 月間開催パラメータ取得_保管庫に追記_完全修正版
    Next r

    'Next i
End Sub

'==================================================
' 月間開催パラメータ取得（完全修正版）
' 参照  : メインテーブル
' 書込先: パラメータ保管庫
'
' ■今回の重要修正
'   対象月のページには翌月4日あたりまで表示されるため、
'   「開始日が対象月の開催だけ」を登録する
'   → 翌月開始開催の誤登録を防止
'==================================================
Public Sub 月間開催パラメータ取得_保管庫に追記_完全修正版()

    Dim wsParam As Worksheet
    Dim wsOut As Worksheet

    Dim yyyy As Long
    Dim mm As Long
    Dim ym As String
    Dim url As String

    Dim http As Object
    Dim html As Object
    Dim tables As Object
    Dim tbl As Object
    Dim trs As Object
    Dim tr As Object
    Dim tds As Object
    Dim td As Object

    Dim i As Long
    Dim jcd As String
    Dim hitCount As Long

    On Error GoTo EH

    Set wsParam = ThisWorkbook.Worksheets("メインテーブル")
    Set wsOut = ThisWorkbook.Worksheets("パラメータ保管庫")

    If Trim$(wsParam.Range("K6").value) = "" Or Trim$(wsParam.Range("K8").value) = "" Then
        MsgBox "メインテーブル!K6 に年、K8 に月を入力してください。", vbExclamation
        Exit Sub
    End If

    yyyy = CLng(wsParam.Range("K6").value)
    mm = CLng(wsParam.Range("K8").value)
    ym = Format$(yyyy, "0000") & Format$(mm, "00")

    url = "https://www.boatrace.jp/owpc/pc/race/monthlyschedule?ym=" & ym

    Set http = CreateObject("MSXML2.XMLHTTP")
    
    http.Open "GET", url, False
    http.setRequestHeader "User-Agent", "Mozilla/5.0"
    http.Send

    If http.Status <> 200 Then
        MsgBox "月間スケジュール取得失敗" & vbCrLf & _
               "Status = " & http.Status & vbCrLf & _
               url, vbCritical
        Exit Sub
    End If

    Set html = CreateObject("HTMLFILE")
    html.body.innerHTML = http.responseText

    保管庫見出し作成 wsOut

    Set tables = html.getElementsByTagName("table")

    hitCount = 0

    For i = 0 To tables.Length - 1

        Set tbl = tables(i)
        Set trs = tbl.getElementsByTagName("tr")

        If trs.Length = 0 Then GoTo NextTable

        ' このテーブルのヘッダー日付を作る
        Dim headerDates() As String
        If Not BuildHeaderDatesFromTable(tbl, yyyy, mm, headerDates) Then GoTo NextTable

        Dim r As Long
        For r = 0 To trs.Length - 1

            Set tr = trs(r)
            jcd = GetJcdFromRow(tr)

            If jcd <> "" Then
                Set tds = tr.getElementsByTagName("td")

                Dim cursorPos As Long
                cursorPos = 1

                Dim c As Long
                For c = 0 To tds.Length - 1

                    Set td = tds(c)

                    Dim span As Long
                    span = GetTdColspan(td)

                    If IsEventCell(td) Then
                        Dim startYmd As String
                        Dim endYmd As String

                        If cursorPos >= 1 And cursorPos <= UBound(headerDates) Then
                            startYmd = headerDates(cursorPos)
                        Else
                            startYmd = ""
                        End If

                        If cursorPos + span - 1 >= 1 And cursorPos + span - 1 <= UBound(headerDates) Then
                            endYmd = headerDates(cursorPos + span - 1)
                        Else
                            endYmd = ""
                        End If

                        '=============================
                        ' ここが今回の核心修正
                        ' 「開始日が対象月の開催だけ」を登録する
                        ' これで翌月1日開始～翌月4日終了のような開催を
                        ' 当月取得で誤登録しない
                        '=============================
                        If startYmd <> "" And endYmd <> "" Then
                            If IsYmdInTargetMonth(startYmd, yyyy, mm) Then
                                保管庫へ1件追加_5列ブロック wsOut, startYmd, endYmd, Format$(Val(jcd), "00")
                                hitCount = hitCount + 1
                            End If
                        End If
                    End If

                    cursorPos = cursorPos + span
                Next c
            End If
        Next r

NextTable:
    Next i

    保管庫重複削除とソート wsOut
    
    ' D, I, N ... の出走表リンクを作り直す
Call 全会場_出走表リンク作成

' 行程日数列 E, J, O ... DK, DP を最終データ行まで整理
行程日数関数設定_シート wsOut

'MsgBox "完了しました。" & vbCrLf & _
       "対象年月: " & ym & vbCrLf & _
       "取得件数(追記前): " & hitCount & " 件", vbInformation
Exit Sub
EH:
    MsgBox "エラー: " & Err.Number & vbCrLf & Err.Description, vbCritical
End Sub

'==================================================
' yyyymmdd が対象年月か判定
'==================================================
Private Function IsYmdInTargetMonth(ByVal ymd As String, _
                                    ByVal targetYear As Long, _
                                    ByVal targetMonth As Long) As Boolean
    Dim targetYm As String

    IsYmdInTargetMonth = False

    ymd = Trim$(ymd)
    If Len(ymd) <> 8 Then Exit Function
    If Not IsNumeric(ymd) Then Exit Function

    targetYm = Format$(targetYear, "0000") & Format$(targetMonth, "00")

    If Left$(ymd, 6) = targetYm Then
        IsYmdInTargetMonth = True
    End If
End Function

'==================================================
' テーブルのヘッダー行から日付配列を組み立てる
'==================================================
Private Function BuildHeaderDatesFromTable(ByVal tbl As Object, _
                                           ByVal targetYear As Long, _
                                           ByVal targetMonth As Long, _
                                           ByRef headerDates() As String) As Boolean

    Dim trs As Object
    Dim tr As Object
    Dim ths As Object
    Dim i As Long
    Dim dayNums() As Long

    BuildHeaderDatesFromTable = False

    Set trs = tbl.getElementsByTagName("tr")
    If trs Is Nothing Then Exit Function
    If trs.Length = 0 Then Exit Function

    For i = 0 To trs.Length - 1
        Set tr = trs(i)
        Set ths = tr.getElementsByTagName("th")

        If Not ths Is Nothing Then
            If ths.Length >= 10 Then
                If ParseHeaderDayNumbers(tr, dayNums) Then
                    Exit For
                End If
            End If
        End If
    Next i

    If Not IsArrayAllocatedLong(dayNums) Then Exit Function
    If UBound(dayNums) < 1 Then Exit Function

    ReDim headerDates(1 To UBound(dayNums))

    Dim curY As Long, curM As Long
    Dim prevD As Long
    Dim d As Long

    If dayNums(1) > 7 Then
        Dim prevMonthDate As Date
        prevMonthDate = DateSerial(targetYear, targetMonth, 1) - 1
        curY = year(prevMonthDate)
        curM = Month(prevMonthDate)
    Else
        curY = targetYear
        curM = targetMonth
    End If

    prevD = dayNums(1)
    headerDates(1) = Format$(DateSerial(curY, curM, prevD), "yyyymmdd")

    For d = 2 To UBound(dayNums)
        If dayNums(d) < prevD Then
            Dim dtNext As Date
            dtNext = DateSerial(curY, curM + 1, 1)
            curY = year(dtNext)
            curM = Month(dtNext)
        End If

        headerDates(d) = Format$(DateSerial(curY, curM, dayNums(d)), "yyyymmdd")
        prevD = dayNums(d)
    Next d

    BuildHeaderDatesFromTable = True
End Function

Private Function ParseHeaderDayNumbers(ByVal tr As Object, ByRef dayNums() As Long) As Boolean

    Dim ths As Object
    Dim i As Long
    Dim txt As String
    Dim dayVal As Long
    Dim n As Long

    ParseHeaderDayNumbers = False

    Set ths = tr.getElementsByTagName("th")
    If ths Is Nothing Then Exit Function
    If ths.Length < 2 Then Exit Function

    n = 0

    For i = 1 To ths.Length - 1
        txt = ths(i).innerText
        dayVal = ExtractLeadingDayNumber(txt)

        If dayVal >= 1 And dayVal <= 31 Then
            n = n + 1
            ReDim Preserve dayNums(1 To n)
            dayNums(n) = dayVal
        End If
    Next i

    If n > 0 Then ParseHeaderDayNumbers = True
End Function

Private Function ExtractLeadingDayNumber(ByVal s As String) As Long

    Dim i As Long
    Dim buf As String
    Dim ch As String

    s = Replace(s, vbCr, "")
    s = Replace(s, vbLf, "")
    s = Replace(s, " ", "")
    s = Replace(s, "　", "")

    buf = ""
    For i = 1 To Len(s)
        ch = mid$(s, i, 1)
        If ch >= "0" And ch <= "9" Then
            buf = buf & ch
        Else
            If buf <> "" Then Exit For
        End If
    Next i

    If buf <> "" Then
        ExtractLeadingDayNumber = CLng(buf)
    Else
        ExtractLeadingDayNumber = 0
    End If
End Function

Private Function IsEventCell(ByVal td As Object) As Boolean

    Dim cls As String
    Dim txt As String
    Dim span As Long

    IsEventCell = False

    On Error Resume Next
    cls = LCase$(CStr(td.className))
    txt = Trim$(CStr(td.innerText))
    On Error GoTo 0

    span = GetTdColspan(td)

    If InStr(cls, "is-gradecolor") > 0 Then
        IsEventCell = True
        Exit Function
    End If

    If span > 1 And txt <> "" And txt <> ChrW(&HA0) Then
        IsEventCell = True
        Exit Function
    End If
End Function

Private Sub 保管庫へ1件追加_5列ブロック(ByVal ws As Worksheet, _
                              ByVal startYmd As String, _
                              ByVal endYmd As String, _
                              ByVal jcd As String)

    Dim blockStartCol As Long
    Dim nextRow As Long

    blockStartCol = GetVenueBlockStartCol(jcd)
    If blockStartCol = 0 Then Exit Sub

    nextRow = GetNextRowInBlock(ws, blockStartCol)

    ws.cells(nextRow, blockStartCol).NumberFormat = "@"
    ws.cells(nextRow, blockStartCol + 1).NumberFormat = "@"
    ws.cells(nextRow, blockStartCol + 2).NumberFormat = "@"

    ws.cells(nextRow, blockStartCol).value = startYmd
    ws.cells(nextRow, blockStartCol + 1).value = endYmd
    ws.cells(nextRow, blockStartCol + 2).value = jcd
    ws.cells(nextRow, blockStartCol + 3).value = ""
    ws.cells(nextRow, blockStartCol + 4).value = ""
End Sub

Private Function GetVenueBlockStartCol(ByVal jcd As String) As Long
    Dim n As Long

    If Not IsNumeric(jcd) Then
        GetVenueBlockStartCol = 0
        Exit Function
    End If

    n = CLng(jcd)

    If n < 1 Or n > 24 Then
        GetVenueBlockStartCol = 0
    Else
        GetVenueBlockStartCol = 1 + (n - 1) * 5
    End If
End Function

Private Function GetNextRowInBlock(ByVal ws As Worksheet, ByVal blockStartCol As Long) As Long

    Dim lastRowA As Long
    Dim lastRowB As Long
    Dim lastRowC As Long
    Dim lastRow As Long

    lastRowA = ws.cells(ws.rows.count, blockStartCol).End(xlUp).Row
    lastRowB = ws.cells(ws.rows.count, blockStartCol + 1).End(xlUp).Row
    lastRowC = ws.cells(ws.rows.count, blockStartCol + 2).End(xlUp).Row

    lastRow = Application.WorksheetFunction.Max(lastRowA, lastRowB, lastRowC)

    If lastRow < 2 Then
        GetNextRowInBlock = 2
    ElseIf Trim$(CStr(ws.cells(lastRow, blockStartCol).value)) = "" _
       And Trim$(CStr(ws.cells(lastRow, blockStartCol + 1).value)) = "" _
       And Trim$(CStr(ws.cells(lastRow, blockStartCol + 2).value)) = "" Then
        GetNextRowInBlock = lastRow
    Else
        GetNextRowInBlock = lastRow + 1
    End If
End Function

Private Sub 保管庫重複削除とソート(ByVal ws As Worksheet)

    Dim j As Long
    Dim blockStartCol As Long

    For j = 1 To 24
        blockStartCol = 1 + (j - 1) * 5
        会場ブロック重複削除とソート ws, blockStartCol
    Next j
End Sub

Private Sub 会場ブロック重複削除とソート(ByVal ws As Worksheet, ByVal blockStartCol As Long)

    Dim lastRow As Long
    Dim r As Long

    Dim startYmd As String
    Dim endYmd As String
    Dim jcd As String

    Dim dictStart As Object
    Dim dictEnd As Object
    Dim key As String

    Dim arr1() As Variant
    Dim arr2() As Variant
    Dim n As Long
    Dim i As Long
    Dim v As Variant

    lastRow = Application.WorksheetFunction.Max( _
                ws.cells(ws.rows.count, blockStartCol).End(xlUp).Row, _
                ws.cells(ws.rows.count, blockStartCol + 1).End(xlUp).Row, _
                ws.cells(ws.rows.count, blockStartCol + 2).End(xlUp).Row)

    If lastRow < 2 Then Exit Sub

    Set dictStart = CreateObject("Scripting.Dictionary")

    For r = 2 To lastRow
        startYmd = Trim$(CStr(ws.cells(r, blockStartCol).value))
        endYmd = Trim$(CStr(ws.cells(r, blockStartCol + 1).value))
        jcd = Trim$(CStr(ws.cells(r, blockStartCol + 2).value))

        If startYmd <> "" And endYmd <> "" And jcd <> "" Then
            key = startYmd & "|" & jcd
            If Not dictStart.Exists(key) Then
                dictStart.Add key, Array(startYmd, endYmd, jcd)
            End If
        End If
    Next r

    If dictStart.count = 0 Then
        ws.Range(ws.cells(2, blockStartCol), ws.cells(lastRow, blockStartCol + 4)).ClearContents
        Exit Sub
    End If

    ReDim arr1(1 To dictStart.count, 1 To 3)
    n = 0
    For Each v In dictStart.items
        n = n + 1
        arr1(n, 1) = v(0)
        arr1(n, 2) = v(1)
        arr1(n, 3) = v(2)
    Next v

    Set dictEnd = CreateObject("Scripting.Dictionary")

    For i = 1 To UBound(arr1, 1)
        startYmd = CStr(arr1(i, 1))
        endYmd = CStr(arr1(i, 2))
        jcd = CStr(arr1(i, 3))

        key = endYmd & "|" & jcd

        If Not dictEnd.Exists(key) Then
            dictEnd.Add key, Array(startYmd, endYmd, jcd)
        Else
            If startYmd < CStr(dictEnd(key)(0)) Then
                dictEnd(key) = Array(startYmd, endYmd, jcd)
            End If
        End If
    Next i

    ws.Range(ws.cells(2, blockStartCol), ws.cells(lastRow, blockStartCol + 4)).ClearContents

    ReDim arr2(1 To dictEnd.count, 1 To 3)
    n = 0
    For Each v In dictEnd.items
        n = n + 1
        arr2(n, 1) = v(0)
        arr2(n, 2) = v(1)
        arr2(n, 3) = v(2)
    Next v

    Sort3ColArray arr2

    For i = 1 To UBound(arr2, 1)
        ws.cells(i + 1, blockStartCol).NumberFormat = "@"
        ws.cells(i + 1, blockStartCol + 1).NumberFormat = "@"
        ws.cells(i + 1, blockStartCol + 2).NumberFormat = "@"

        ws.cells(i + 1, blockStartCol).value = arr2(i, 1)
        ws.cells(i + 1, blockStartCol + 1).value = arr2(i, 2)
        ws.cells(i + 1, blockStartCol + 2).value = arr2(i, 3)
        ws.cells(i + 1, blockStartCol + 3).value = ""
        ws.cells(i + 1, blockStartCol + 4).value = ""
    Next i
End Sub

Private Sub Sort3ColArray(ByRef arr As Variant)

    Dim i As Long
    Dim j As Long
    Dim tmp1 As Variant
    Dim tmp2 As Variant
    Dim tmp3 As Variant

    For i = 1 To UBound(arr, 1) - 1
        For j = i + 1 To UBound(arr, 1)
            If CStr(arr(i, 1)) > CStr(arr(j, 1)) _
               Or (CStr(arr(i, 1)) = CStr(arr(j, 1)) And CStr(arr(i, 2)) > CStr(arr(j, 2))) _
               Or (CStr(arr(i, 1)) = CStr(arr(j, 1)) And CStr(arr(i, 2)) = CStr(arr(j, 2)) And CStr(arr(i, 3)) > CStr(arr(j, 3))) Then

                tmp1 = arr(i, 1)
                tmp2 = arr(i, 2)
                tmp3 = arr(i, 3)

                arr(i, 1) = arr(j, 1)
                arr(i, 2) = arr(j, 2)
                arr(i, 3) = arr(j, 3)

                arr(j, 1) = tmp1
                arr(j, 2) = tmp2
                arr(j, 3) = tmp3
            End If
        Next j
    Next i
End Sub

Private Sub 保管庫見出し作成(ByVal ws As Worksheet)

    Dim venueNames As Variant
    Dim j As Long
    Dim c As Long

    venueNames = Array( _
        "桐生", "戸田", "江戸川", "平和島", "多摩川", "浜名湖", _
        "蒲郡", "常滑", "津", "三国", "びわこ", "住之江", _
        "尼崎", "鳴門", "丸亀", "児島", "宮島", "徳山", _
        "下関", "若松", "芦屋", "福岡", "唐津", "大村")

    For j = 1 To 24
        c = 1 + (j - 1) * 5
        If Trim$(CStr(ws.cells(1, c).value)) = "" Then
            ws.cells(1, c).value = venueNames(j - 1)
        End If
    Next j
End Sub

Private Function GetJcdFromRow(ByVal tr As Object) As String

    Dim ths As Object
    Dim th As Object
    Dim anchors As Object
    Dim a As Object
    Dim href As String
    Dim jcd As String

    GetJcdFromRow = ""

    On Error Resume Next
    Set ths = tr.getElementsByTagName("th")
    On Error GoTo 0

    If ths Is Nothing Then Exit Function
    If ths.Length = 0 Then Exit Function

    Set th = ths(0)

    On Error Resume Next
    Set anchors = th.getElementsByTagName("a")
    On Error GoTo 0

    If anchors Is Nothing Then Exit Function
    If anchors.Length = 0 Then Exit Function

    Set a = anchors(0)
    href = GetHrefSafe(a)
    jcd = GetQueryParam(href, "jcd")

    If Len(jcd) > 0 Then GetJcdFromRow = Format$(Val(jcd), "00")
End Function

Private Function GetTdColspan(ByVal td As Object) As Long

    Dim v As Variant

    GetTdColspan = 1

    On Error Resume Next
    v = td.getAttribute("colspan")
    On Error GoTo 0

    If IsNumeric(v) Then
        GetTdColspan = CLng(v)
        If GetTdColspan <= 0 Then GetTdColspan = 1
    End If
End Function

Private Function GetHrefSafe(ByVal elm As Object) As String

    Dim v As Variant

    GetHrefSafe = ""
    If elm Is Nothing Then Exit Function

    On Error Resume Next

    v = elm.href
    If Err.Number = 0 Then
        If Not IsNull(v) Then
            GetHrefSafe = Trim$(CStr(v))
            If GetHrefSafe <> "" Then Exit Function
        End If
    End If

    Err.Clear

    v = elm.getAttribute("href")
    If Err.Number = 0 Then
        If Not IsNull(v) Then
            GetHrefSafe = Trim$(CStr(v))
            If GetHrefSafe <> "" Then Exit Function
        End If
    End If

    On Error GoTo 0
End Function

Private Function GetQueryParam(ByVal url As String, ByVal key As String) As String

    Dim qPos As Long
    Dim qs As String
    Dim arr() As String
    Dim i As Long
    Dim kv() As String

    GetQueryParam = ""

    qPos = InStr(url, "?")
    If qPos = 0 Then Exit Function

    qs = mid$(url, qPos + 1)
    arr = Split(qs, "&")

    For i = LBound(arr) To UBound(arr)
        kv = Split(arr(i), "=")
        If UBound(kv) >= 1 Then
            If LCase$(Trim$(kv(0))) = LCase$(key) Then
                GetQueryParam = Trim$(kv(1))
                Exit Function
            End If
        End If
    Next i
End Function

Private Function IsArrayAllocatedLong(ByRef arr() As Long) As Boolean
    On Error GoTo EH
    If UBound(arr) >= LBound(arr) Then
        IsArrayAllocatedLong = True
    Else
        IsArrayAllocatedLong = False
    End If
    Exit Function
EH:
    IsArrayAllocatedLong = False
End Function
Public Sub 全会場_出走表リンク作成()

    Dim ws As Worksheet
    Dim blockStartCol As Long
    Dim linkCol As Long
    Dim jcdCol As Long
    Dim lastRow As Long
    Dim r As Long
    
    Dim ymd As String
    Dim jcd As String
    Dim url As String
    
    Set ws = ThisWorkbook.Worksheets("パラメータ保管庫")
    
    Application.ScreenUpdating = False
    
    ' A列開始～DI列開始まで（24会場 × 5列 = 120列, 開始列は 1,6,11,...,116）
    For blockStartCol = 1 To 116 Step 5
        
        jcdCol = blockStartCol + 2
        linkCol = blockStartCol + 3
        
        lastRow = Application.WorksheetFunction.Max( _
                    ws.cells(ws.rows.count, blockStartCol).End(xlUp).Row, _
                    ws.cells(ws.rows.count, jcdCol).End(xlUp).Row)
        
        For r = 2 To lastRow
            
            ymd = Trim$(CStr(ws.cells(r, blockStartCol).value))
            jcd = Trim$(CStr(ws.cells(r, jcdCol).value))
            
            If ymd <> "" And jcd <> "" Then
                
                url = "https://www.boatrace.jp/owpc/pc/race/racelist?hd=" & ymd & _
                      "&jcd=" & jcd & "&rno=1"
                
                ' 既存リンク削除
                On Error Resume Next
                ws.cells(r, linkCol).Hyperlinks.Delete
                On Error GoTo 0
                
                ' 表示文字も一度クリア
                ws.cells(r, linkCol).ClearContents
                
                ws.Hyperlinks.Add _
                    Anchor:=ws.cells(r, linkCol), _
                    address:=url, _
                    TextToDisplay:="出走表"
            Else
                ' 値がない行はリンク削除
                On Error Resume Next
                ws.cells(r, linkCol).Hyperlinks.Delete
                On Error GoTo 0
                ws.cells(r, linkCol).ClearContents
            End If
            
        Next r
    Next blockStartCol
    
    Application.ScreenUpdating = True
    
    MsgBox "全会場の出走表リンク作成が完了しました。", vbInformation

End Sub

'==================================================
' 全会場の行程日数列に関数を入れる
'
' 対象列:
' E, J, O ... DK, DP
'
' 内容:
' 終了日 - 開始日 + 1
'
' ・各会場の最終データ行までだけ関数を入れる
' ・それより下の古い関数や #VALUE! を消す
' ・1行目の #VALUE! は「行程日数」に置き換える
'==================================================
Public Sub 全会場_行程日数関数作成()

    Dim ws As Worksheet

    Set ws = ThisWorkbook.Worksheets("パラメータ保管庫")

    Application.ScreenUpdating = False

    行程日数関数設定_シート ws

    Application.ScreenUpdating = True

    MsgBox "全会場の行程日数関数を整理しました。", vbInformation

End Sub


Private Sub 行程日数関数設定_シート(ByVal ws As Worksheet)

    Dim blockStartCol As Long
    Dim daysCol As Long

    Dim lastRowStart As Long
    Dim lastRowEnd As Long
    Dim lastRowJcd As Long
    Dim lastDataRow As Long
    Dim oldFormulaLastRow As Long
    Dim clearLastRow As Long

    Dim f As String

    ' E列基準のR1C1式
    ' RC[-4] = 開始日
    ' RC[-3] = 終了日
    f = "=IFERROR(IF(OR(RC[-4]="""",RC[-3]=""""),""""," & _
        "DATE(--LEFT(RC[-3],4),--MID(RC[-3],5,2),--RIGHT(RC[-3],2))" & _
        "-DATE(--LEFT(RC[-4],4),--MID(RC[-4],5,2),--RIGHT(RC[-4],2))+1),"""")"

    ' A列開始～DL列開始まで
    ' 24会場 × 5列
    ' 日数列は blockStartCol + 4
    For blockStartCol = 1 To 116 Step 5

        daysCol = blockStartCol + 4

        ' 1行目の #VALUE! 掃除
        ws.cells(1, daysCol).ClearContents
        ws.cells(1, daysCol).value = "行程日数"

        ' この会場ブロックの最終データ行を判定
        lastRowStart = ws.cells(ws.rows.count, blockStartCol).End(xlUp).Row
        lastRowEnd = ws.cells(ws.rows.count, blockStartCol + 1).End(xlUp).Row
        lastRowJcd = ws.cells(ws.rows.count, blockStartCol + 2).End(xlUp).Row

        lastDataRow = lastRowStart
        If lastRowEnd > lastDataRow Then lastDataRow = lastRowEnd
        If lastRowJcd > lastDataRow Then lastDataRow = lastRowJcd

        ' 既に日数列に残っている古い関数の最終行
        oldFormulaLastRow = ws.cells(ws.rows.count, daysCol).End(xlUp).Row

        clearLastRow = lastDataRow
        If oldFormulaLastRow > clearLastRow Then clearLastRow = oldFormulaLastRow

        ' 2行目以降の日数列をいったん掃除
        If clearLastRow >= 2 Then
            ws.Range(ws.cells(2, daysCol), ws.cells(clearLastRow, daysCol)).ClearContents
        End If

        ' データがある行だけ関数を入れる
        If lastDataRow >= 2 Then
            With ws.Range(ws.cells(2, daysCol), ws.cells(lastDataRow, daysCol))
                .FormulaR1C1 = f
                .NumberFormat = "0"
            End With
        End If

    Next blockStartCol

End Sub
Public Sub PowerQuery公開用_開催日程_縦持ちxlsx作成()

    Const SRC_BOOK_BASE As String = "データ集積2026"
    Const SRC_SHEET_NAME As String = "パラメータ保管庫"
    
    Const OUT_FILE_NAME As String = "power-query-kyotei-schedule-raw.xlsx"
    Const OUT_SHEET_NAME As String = "schedule_raw"
    Const OUT_TABLE_NAME As String = "tbl_schedule_raw"
    
    Dim wbSrc As Workbook
    Dim wsSrc As Worksheet
    
    Dim wbOut As Workbook
    Dim wsOut As Worksheet
    
    Dim targetPath As String
    Dim lastRow As Long
    Dim lastCol As Long
    Dim blockStartCol As Long
    Dim r As Long
    
    Dim venueName As String
    Dim startVal As Variant
    Dim endVal As Variant
    Dim jcdVal As Variant
    Dim typeVal As Variant
    Dim daysVal As Variant
    
    Dim startText As String
    Dim endText As String
    Dim jcdText As String
    Dim dataTypeText As String
    Dim daysOut As Variant
    
    Dim maxRows As Long
    Dim outCnt As Long
    Dim tmpArr() As Variant
    Dim outArr() As Variant
    Dim i As Long
    Dim c As Long
    
    Dim lo As ListObject
    Dim rngTable As Range
    Dim lastCell As Range
    Dim wb As Workbook
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    On Error GoTo ErrHandler
    
    'データ集積2026 ブックを探す
    Set wbSrc = GetOpenWorkbookByBaseName(SRC_BOOK_BASE)
    
    If wbSrc Is Nothing Then
        MsgBox "ブック「" & SRC_BOOK_BASE & "」が開かれていません。" & vbCrLf & _
               "先に データ集積2026 を開いてから実行してください。", vbExclamation
        GoTo FinallyExit
    End If
    
    If Len(wbSrc.path) = 0 Then
        MsgBox "ブック「" & wbSrc.Name & "」がまだ保存されていません。" & vbCrLf & _
               "先に保存してください。", vbExclamation
        GoTo FinallyExit
    End If
    
    '元シート確認
    On Error Resume Next
    Set wsSrc = wbSrc.Worksheets(SRC_SHEET_NAME)
    On Error GoTo ErrHandler
    
    If wsSrc Is Nothing Then
        MsgBox "ブック「" & wbSrc.Name & "」の中に" & vbCrLf & _
               "シート「" & SRC_SHEET_NAME & "」が見つかりません。", vbExclamation
        GoTo FinallyExit
    End If
    
    targetPath = wbSrc.path & Application.PathSeparator & OUT_FILE_NAME
    
    '出力先ファイルが開いていたら中止
    For Each wb In Application.Workbooks
        If StrComp(wb.FullName, targetPath, vbTextCompare) = 0 Then
            MsgBox OUT_FILE_NAME & " が開いています。" & vbCrLf & _
                   "閉じてから再実行してください。", vbExclamation
            GoTo FinallyExit
        End If
    Next wb
    
    '最終行・最終列取得
    Set lastCell = wsSrc.cells.Find(What:="*", _
                                    LookIn:=xlValues, _
                                    SearchOrder:=xlByRows, _
                                    SearchDirection:=xlPrevious)
                                    
    If lastCell Is Nothing Then
        MsgBox "元シートにデータがありません。", vbExclamation
        GoTo FinallyExit
    End If
    
    lastRow = lastCell.Row
    
    Set lastCell = wsSrc.cells.Find(What:="*", _
                                    LookIn:=xlValues, _
                                    SearchOrder:=xlByColumns, _
                                    SearchDirection:=xlPrevious)
    lastCol = lastCell.Column
    
    '最大行数を仮確保
    maxRows = ((lastCol + 4) \ 5) * (lastRow - 1)
    ReDim tmpArr(1 To maxRows, 1 To 6)
    
    '5列ごとに1会場として縦持ち化
    For blockStartCol = 1 To lastCol Step 5
        
        If blockStartCol + 4 <= wsSrc.Columns.count Then
            
            If Not IsError(wsSrc.cells(1, blockStartCol).value) Then
                venueName = Trim$(CStr(wsSrc.cells(1, blockStartCol).value))
            Else
                venueName = ""
            End If
            
            If Len(venueName) > 0 Then
                
                For r = 2 To lastRow
                    
                    startVal = wsSrc.cells(r, blockStartCol).value
                    endVal = wsSrc.cells(r, blockStartCol + 1).value
                    jcdVal = wsSrc.cells(r, blockStartCol + 2).value
                    typeVal = wsSrc.cells(r, blockStartCol + 3).value
                    daysVal = wsSrc.cells(r, blockStartCol + 4).value
                    
                    '開始日・終了日・会場コードがエラーなら除外
                    If Not IsError(startVal) _
                       And Not IsError(endVal) _
                       And Not IsError(jcdVal) Then
                       
                        startText = Trim$(CStr(startVal))
                        endText = Trim$(CStr(endVal))
                        jcdText = Trim$(CStr(jcdVal))
                        
                        If Len(startText) > 0 _
                           And Len(endText) > 0 _
                           And Len(jcdText) > 0 Then
                           
                            '会場コードは2桁文字列に統一
                            jcdText = Format$(Val(jcdText), "00")
                            
                            If IsError(typeVal) Or Len(Trim$(CStr(typeVal))) = 0 Then
                                dataTypeText = "出走表"
                            Else
                                dataTypeText = Trim$(CStr(typeVal))
                            End If
                            
                            '行程日数
                            If IsError(daysVal) Or Len(Trim$(CStr(daysVal))) = 0 Then
                                daysOut = CalcDaysFromYmdText(startText, endText)
                            ElseIf IsNumeric(daysVal) Then
                                daysOut = CLng(daysVal)
                            Else
                                daysOut = CalcDaysFromYmdText(startText, endText)
                            End If
                            
                            outCnt = outCnt + 1
                            
                            tmpArr(outCnt, 1) = jcdText
                            tmpArr(outCnt, 2) = venueName
                            tmpArr(outCnt, 3) = startText
                            tmpArr(outCnt, 4) = endText
                            tmpArr(outCnt, 5) = dataTypeText
                            tmpArr(outCnt, 6) = daysOut
                            
                        End If
                        
                    End If
                    
                Next r
                
            End If
            
        End If
        
    Next blockStartCol
    
    If outCnt = 0 Then
        MsgBox "縦持ち化できるデータがありませんでした。" & vbCrLf & _
               "元シートの構造を確認してください。", vbExclamation
        GoTo FinallyExit
    End If
    
    'ぴったりサイズの配列に詰め替え
    ReDim outArr(1 To outCnt, 1 To 6)
    
    For i = 1 To outCnt
        For c = 1 To 6
            outArr(i, c) = tmpArr(i, c)
        Next c
    Next i
    
    '既存ファイルを削除して上書き準備
    If Dir(targetPath) <> "" Then
        Kill targetPath
    End If
    
    '新規ブック作成
    Set wbOut = Workbooks.Add(xlWBATWorksheet)
    Set wsOut = wbOut.Worksheets(1)
    wsOut.Name = OUT_SHEET_NAME
    
    '見出し
    wsOut.Range("A1:F1").value = Array("jcd", "venue_name", "start_date", "end_date", "data_type", "days")
    
    '値書き込み
    wsOut.Range("A2").Resize(outCnt, 6).value = outArr
    
    'Power Queryで扱いやすいように整える
    wsOut.Columns("A:E").NumberFormat = "@"
    wsOut.Columns("F:F").NumberFormat = "0"
    
    'テーブル化
    Set rngTable = wsOut.Range("A1").CurrentRegion
    Set lo = wsOut.ListObjects.Add(xlSrcRange, rngTable, , xlYes)
    lo.Name = OUT_TABLE_NAME
    lo.TableStyle = "TableStyleMedium2"
    
    '見た目調整
    wsOut.rows(1).Font.Bold = True
    wsOut.Columns("A:F").AutoFit
    wsOut.Range("A2").Select
    ActiveWindow.FreezePanes = True
    
    'xlsxとして保存
    Application.DisplayAlerts = False
    wbOut.SaveAs fileName:=targetPath, FileFormat:=xlOpenXMLWorkbook
    wbOut.Close SaveChanges:=False
    Application.DisplayAlerts = True
    
    MsgBox "Power Query公開用ファイルを作成しました。" & vbCrLf & vbCrLf & _
           "保存先：" & targetPath & vbCrLf & _
           "出力件数：" & outCnt & " 行" & vbCrLf & _
           "シート名：" & OUT_SHEET_NAME & vbCrLf & _
           "テーブル名：" & OUT_TABLE_NAME, vbInformation

FinallyExit:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub

ErrHandler:
    MsgBox "エラーが発生しました。" & vbCrLf & _
           "番号：" & Err.Number & vbCrLf & _
           "内容：" & Err.Description, vbCritical
    Resume FinallyExit

End Sub


Private Function GetOpenWorkbookByBaseName(ByVal baseName As String) As Workbook

    Dim wb As Workbook
    Dim nm As String
    
    For Each wb In Application.Workbooks
        
        nm = wb.Name
        
        '拡張子を除いたブック名で判定
        If InStr(1, nm, baseName, vbTextCompare) > 0 Then
            Set GetOpenWorkbookByBaseName = wb
            Exit Function
        End If
        
    Next wb
    
    Set GetOpenWorkbookByBaseName = Nothing

End Function


Private Function CalcDaysFromYmdText(ByVal startText As String, ByVal endText As String) As Variant

    Dim sY As Long, sM As Long, sD As Long
    Dim eY As Long, eM As Long, eD As Long
    Dim d1 As Date, d2 As Date
    
    On Error GoTo ErrHandler
    
    startText = Replace(startText, "/", "")
    startText = Replace(startText, "-", "")
    
    endText = Replace(endText, "/", "")
    endText = Replace(endText, "-", "")
    
    If Len(startText) <> 8 Or Len(endText) <> 8 Then
        CalcDaysFromYmdText = ""
        Exit Function
    End If
    
    sY = CLng(Left$(startText, 4))
    sM = CLng(mid$(startText, 5, 2))
    sD = CLng(Right$(startText, 2))
    
    eY = CLng(Left$(endText, 4))
    eM = CLng(mid$(endText, 5, 2))
    eD = CLng(Right$(endText, 2))
    
    d1 = DateSerial(sY, sM, sD)
    d2 = DateSerial(eY, eM, eD)
    
    CalcDaysFromYmdText = DateDiff("d", d1, d2) + 1
    Exit Function

ErrHandler:
    CalcDaysFromYmdText = ""

End Function