412 lines
13 KiB
Plaintext
412 lines
13 KiB
Plaintext
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
|
||
|