Option Explicit

' ============================
' CSV エクスポート（UTF-8 BOM付き）
' H6セルのシート名を対象に出力
' 1行目に [code:label] メタがある列は code で出力
' ============================

' === 設定 ===
Private Const EXPORT_UTF8_WITH_BOM As Boolean = True
Private Const STRIP_META_FROM_HEADER As Boolean = False ' Trueにするとヘッダから [x:ラベル] を削除して出力

' 入口：ボタンに割り当て
Public Sub Run_ExportCsv_FromH6()
    Dim ctrl As Worksheet
    Set ctrl = ActiveSheet

    Dim targetName As String
    targetName = Trim$(Nz(ctrl.Range("H6").value, ""))
    If Len(targetName) = 0 Then
        MsgBox "H6セルに出力対象のシート名がありません。", vbExclamation
        Exit Sub
    End If
    If Not SheetExists(targetName) Then
        MsgBox "シート """ & targetName & """ が見つかりません。", vbExclamation
        Exit Sub
    End If

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(targetName)

    ExportCsvWithMeta ws
End Sub

' === 本体 ===
Private Sub ExportCsvWithMeta(ByVal ws As Worksheet)
    Dim lastRow As Long, lastCol As Long
    lastRow = GetLastRow(ws)
    lastCol = GetLastCol(ws)
    If lastRow = 0 Or lastCol = 0 Then
        MsgBox "対象シートが空です。", vbExclamation
        Exit Sub
    End If

    ' ヘッダ行（1行目）を読み、列ごとにメタ（[code:label]）を辞書化
    Dim colHasEnum() As Boolean
    Dim mapLabelToCode() As Object ' Scripting.Dictionary（label→code）
    Dim setValidCode() As Object    ' Scripting.Dictionary（code→True）
    ReDim colHasEnum(1 To lastCol)
    ReDim mapLabelToCode(1 To lastCol)
    ReDim setValidCode(1 To lastCol)

    Dim c As Long
    For c = 1 To lastCol
        Dim headerRaw As String
        headerRaw = Nz(ws.Cells(1, c).value, "")
        BuildEnumMaps headerRaw, mapLabelToCode(c), setValidCode(c), colHasEnum(c)
    Next c

    ' 一括読み
    Dim rng As Range
    Set rng = ws.Range("A1").Resize(lastRow, lastCol)
    Dim data As Variant
    data = rng.value ' 1-based

    ' CSV行を構築
    Dim sb As String
    Dim r As Long

    ' 1行目（ヘッダ）
    Dim line As String
    line = ""
    For c = 1 To lastCol
        Dim h As String
        h = Nz(data(1, c), "")
        If STRIP_META_FROM_HEADER Then
            h = StripEnumFromHeader(h)
        End If
        AppendCsvField line, h
    Next c
    sb = line

    ' データ行
    For r = 2 To lastRow
        ' 行全体が空ならスキップ（全列空 or 空白のみ）
        If RowIsAllEmpty(data, r, lastCol) Then
            ' スキップ
        Else
            line = ""
            For c = 1 To lastCol
                Dim v As String
                v = Nz(data(r, c), "")

                If colHasEnum(c) Then
                    Dim codeOut As String, ok As Boolean
                    ok = TryResolveToCode(v, mapLabelToCode(c), setValidCode(c), codeOut)
                    If Not ok Then
                        ' エラー表示＆該当セルを選択して中断
                        Dim addr As String
                        addr = ws.Cells(r, c).Address(False, False)
                        MsgBox "列挙メタに一致しない値が見つかりました。" & vbCrLf & _
                               "セル: " & addr & vbCrLf & _
                               "値  : " & v & vbCrLf & _
                               "ヘッダ: " & Nz(data(1, c), ""), vbCritical
                        ws.Activate
                        ws.Cells(r, c).Select
                        Exit Sub
                    End If
                    AppendCsvField line, codeOut
                Else
                    AppendCsvField line, v
                End If
            Next c
            sb = sb & vbCrLf & line
        End If
    Next r

    ' 保存ダイアログ
    Dim fpath As String
    fpath = PickSavePathCsv(ws.Name)
    If Len(fpath) = 0 Then
        MsgBox "保存がキャンセルされました。", vbInformation
        Exit Sub
    End If

    ' UTF-8で書き込み
    If EXPORT_UTF8_WITH_BOM Then
        WriteUtf8WithBom fpath, sb
    Else
        WriteUtf8NoBom fpath, sb
    End If

    MsgBox "CSVの書き出しが完了しました。" & vbCrLf & fpath, vbInformation
End Sub

' === メタ解析（[code:label] または [code：label] を辞書化） ===
Private Sub BuildEnumMaps(ByVal headerRaw As String, _
                          ByRef dictLabelToCode As Object, _
                          ByRef dictValidCode As Object, _
                          ByRef hasEnum As Boolean)
    Dim re As Object, mc As Object, m As Object
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "\[(\d+)[:：]([^\]]+)\]"
    re.IgnoreCase = True
    re.Global = True

    hasEnum = False
    Set dictLabelToCode = CreateObject("Scripting.Dictionary")
    Set dictValidCode = CreateObject("Scripting.Dictionary")

    If re.Test(headerRaw) Then
        Set mc = re.Execute(headerRaw)
        Dim code As String, label As String, key As String
        For Each m In mc
            code = CStr(m.SubMatches(0))
            label = CStr(m.SubMatches(1))
            ' 有効コードセット
            If Not dictValidCode.Exists(code) Then dictValidCode.Add code, True
            ' ラベル→コード（トリム＆半角化キーも登録）
            key = NormalizeKey(label)
            If Not dictLabelToCode.Exists(key) Then dictLabelToCode.Add key, code

            ' ラベルのバリエーション（両端空白除去のみ）
            key = NormalizeKeyBasic(label)
            If Not dictLabelToCode.Exists(key) Then dictLabelToCode.Add key, code

            hasEnum = True
        Next m
    End If
End Sub

' === 値 → code への正規化 ===
' 空は許容（空文字を返す）。一致しなければ False
Private Function TryResolveToCode(ByVal v As String, _
                                  ByVal dictLabelToCode As Object, _
                                  ByVal dictValidCode As Object, _
                                  ByRef outCode As String) As Boolean
    Dim s As String
    s = TrimBoth(v)
    If Len(s) = 0 Then
        outCode = ""
        TryResolveToCode = True
        Exit Function
    End If

    ' 1) "code:label" / "code：label" 形式
    Dim re As Object, m As Object
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "^\s*(\d+)\s*[:：]\s*.+$"
    re.IgnoreCase = True
    re.Global = False
    If re.Test(s) Then
        Set m = re.Execute(s)(0)
        If dictValidCode.Exists(m.SubMatches(0)) Then
            outCode = CStr(m.SubMatches(0))
            TryResolveToCode = True
            Exit Function
        Else
            TryResolveToCode = False
            Exit Function
        End If
    End If

    ' 2) code そのもの
    ' If dictValidCode.Exists(s) Then
    '     outCode = s
    '     TryResolveToCode = True
    '     Exit Function
    ' End If

    ' 2b) 全角→半角にして code 判定
    ' Dim sN As String
    ' On Error Resume Next
    ' sN = StrConv(s, vbNarrow)
    ' On Error GoTo 0
    ' If Len(sN) > 0 Then
    '     If dictValidCode.Exists(sN) Then
    '         outCode = sN
    '         TryResolveToCode = True
    '         Exit Function
    '     End If
    ' End If

    ' 3) label として一致（正規化キーで判定）
    Dim key As String
    key = NormalizeKey(s)
    If dictLabelToCode.Exists(key) Then
        outCode = CStr(dictLabelToCode(key))
        TryResolveToCode = True
        Exit Function
    End If

    ' 3b) ラベル・最小正規化
    key = NormalizeKeyBasic(s)
    If dictLabelToCode.Exists(key) Then
        outCode = CStr(dictLabelToCode(key))
        TryResolveToCode = True
        Exit Function
    End If

    TryResolveToCode = False
End Function

' === ヘッダから [x:ラベル] を削除 ===
Private Function StripEnumFromHeader(ByVal headerRaw As String) As String
    Dim re As Object
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "\[[^\]]+\]"
    re.Global = True
    StripEnumFromHeader = Trim$(re.Replace(headerRaw, ""))
End Function

' === CSVフィールド追加（RFC準拠の引用） ===
Private Sub AppendCsvField(ByRef line As String, ByVal value As String)
    Dim s As String
    s = CStr(value)
    ' 改行はCRLFに正規化
    s = Replace(s, vbCrLf, vbLf)
    s = Replace(s, vbCr, vbLf)
    s = Replace(s, vbLf, vbCrLf)

    ' ダブルクォートは二重化
    If InStr(1, s, """") > 0 Then s = Replace(s, """", """""""")
    ' 区切り・改行・引用符を含む場合は引用
    If (InStr(1, s, ",") > 0) Or (InStr(1, s, vbCrLf) > 0) Or (InStr(1, s, """") > 0) Then
        s = """" & s & """"
    End If

    If Len(line) = 0 Then
        line = s
    Else
        line = line & "," & s
    End If
End Sub

' === 保存ダイアログ ===
Private Function PickSavePathCsv(ByVal baseName As String) As String
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogSaveAs)
    With fd
        .Title = "CSVファイルの保存先を選択"
        .FilterIndex = 1
        .InitialFileName = baseName & "_" & Format(Now, "yymmdd_hhnnss") & ".csv"
        If .Show = -1 Then
            PickSavePathCsv = .SelectedItems(1)
            ' 拡張子補完
            If LCase$(Right$(PickSavePathCsv, 4)) <> ".csv" Then
                PickSavePathCsv = PickSavePathCsv & ".csv"
            End If
        Else
            PickSavePathCsv = ""
        End If
    End With
End Function

' === UTF-8（BOM付き）で書き出し ===
Private Sub WriteUtf8WithBom(ByVal fpath As String, ByVal content As String)
    Dim stmText As Object, stmBin As Object
    Dim bom(2) As Byte
    bom(0) = &HEF: bom(1) = &HBB: bom(2) = &HBF

    ' テキスト→UTF-8 バイトへ
    Set stmText = CreateObject("ADODB.Stream")
    stmText.Type = 2 ' adTypeText
    stmText.Charset = "utf-8"
    stmText.Open
    stmText.WriteText content
    stmText.Position = 0

    ' BOM + 本文をバイナリで保存
    Set stmBin = CreateObject("ADODB.Stream")
    stmBin.Type = 1 ' adTypeBinary
    stmBin.Open
    stmBin.Write bom
    stmText.CopyTo stmBin
    stmBin.SaveToFile fpath, 2 ' adSaveCreateOverWrite

    stmText.Close: stmBin.Close
End Sub

' === UTF-8（BOMなし）で書き出し ===
Private Sub WriteUtf8NoBom(ByVal fpath As String, ByVal content As String)
    Dim stm As Object
    Set stm = CreateObject("ADODB.Stream")
    stm.Type = 2 ' adTypeText
    stm.Charset = "utf-8"
    stm.Open
    stm.WriteText content
    stm.SaveToFile fpath, 2 ' adSaveCreateOverWrite
    stm.Close
End Sub

' === 行が全空か ===
Private Function RowIsAllEmpty(ByRef data As Variant, ByVal r As Long, ByVal lastCol As Long) As Boolean
    Dim c As Long, s As String
    For c = 1 To lastCol
        s = TrimBoth(Nz(data(r, c), ""))
        If Len(s) > 0 Then
            RowIsAllEmpty = False
            Exit Function
        End If
    Next c
    RowIsAllEmpty = True
End Function

' === 便利関数群 ===
Private Function GetLastRow(ByVal ws As Worksheet) As Long
    Dim f As Range
    On Error Resume Next
    Set f = ws.Cells.Find(What:="*", After:=ws.Range("A1"), LookAt:=xlPart, _
                          LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, MatchCase:=False)
    On Error GoTo 0
    If f Is Nothing Then GetLastRow = 0 Else GetLastRow = f.Row
End Function

Private Function GetLastCol(ByVal ws As Worksheet) As Long
    Dim f As Range
    On Error Resume Next
    Set f = ws.Cells.Find(What:="*", After:=ws.Range("A1"), LookAt:=xlPart, _
                          LookIn:=xlFormulas, SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious, MatchCase:=False)
    On Error GoTo 0
    If f Is Nothing Then GetLastCol = 0 Else GetLastCol = f.Column
End Function

Private Function SheetExists(ByVal sName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(sName)
    SheetExists = Not ws Is Nothing
    On Error GoTo 0
End Function

Private Function Nz(ByVal v As Variant, Optional ByVal defaultValue As String = "") As String
    If IsError(v) Then
        Nz = defaultValue
    ElseIf IsNull(v) Or IsEmpty(v) Then
        Nz = defaultValue
    Else
        Nz = CStr(v)
    End If
End Function

' 半角・全角スペースを両方トリム
Private Function TrimBoth(ByVal s As String) As String
    Dim t As String
    t = s
    t = Replace(t, ChrW(&H3000), " ") ' 全角スペース→半角スペース
    TrimBoth = Trim$(t)
End Function

' ラベル用 正規化キー（両端空白除去 + 全角→半角 + 連続空白縮約）
Private Function NormalizeKey(ByVal s As String) As String
    Dim t As String
    t = TrimBoth(s)
    On Error Resume Next
    t = StrConv(t, vbNarrow)
    On Error GoTo 0
    ' 空白の縮約
    Do While InStr(t, "  ") > 0
        t = Replace(t, "  ", " ")
    Loop
    NormalizeKey = t
End Function

' ラベル用 簡易キー（両端トリムのみ）
Private Function NormalizeKeyBasic(ByVal s As String) As String
    NormalizeKeyBasic = TrimBoth(s)
End Function