スクリプトファイルを追加

csv_output_vba.txt

@@ -0,0 +1,411 @@
+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
+