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

csv_maker_vba.txt

@@ -0,0 +1,489 @@
+Option Explicit
+
+' ============================================
+' CSV取り込み + ヘッダ/ドロップダウン設定（列挙メタは改行不問で検知）
+' 実行時に新規シートを作成して結果を出力
+' ============================================
+
+' ===== 設定定数 =====
+Private Const DV_USE_CODE_ONLY As Boolean = True   ' True: ドロップダウンをコードのみ（例: 0,1）にする
+Private Const APPLY_DV_TO_ROW As Long = 50          ' データがない場合にDVを適用する最終行
+Private Const CSV_ENCODING As String = "auto"       ' "auto"|"utf8"|"cp932"
+Private Const SHEET_NAME_PREFIX As String = "Import_" ' 作成シート名の接頭辞
+
+'==== ボタンに割り当てるエントリーポイント ====
+Public Sub Run_ImportCsv_CreateNewSheet()
+    Dim ctrlSheet As Worksheet
+    Set ctrlSheet = ActiveSheet  ' ボタンを置いたシート（操作用）
+
+    ' CSVパスを選択
+    Dim fpath As String
+    fpath = PickCsvFilePath()
+    If Len(fpath) = 0 Then
+        MsgBox "CSVの選択がキャンセルされました。", vbInformation
+        Exit Sub
+    End If
+
+    ' 出力シート名
+    Dim outSheetName As String
+    outSheetName = GetUniqueSheetName(BuildOutputSheetName(fpath))
+
+    ' 新規シート作成（操作用シートの後ろ）
+    Dim wsTarget As Worksheet
+    Set wsTarget = ThisWorkbook.Worksheets.Add(After:=ctrlSheet)
+    wsTarget.Name = outSheetName
+
+    ' 取り込み実行（結果は wsTarget に出力）
+    ImportCsvToTargetSheet fpath, wsTarget
+
+    ' 完了メッセージ
+    MsgBox "取り込み完了: " & wsTarget.Name, vbInformation
+End Sub
+
+'==== メイン処理（指定のターゲットシートに出力） ====
+Private Sub ImportCsvToTargetSheet(ByVal fpath As String, ByVal wsTarget As Worksheet)
+    Dim wsTemp As Worksheet
+    Set wsTemp = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
+    wsTemp.Name = GetUniqueTempSheetName("CSV_RAW")
+
+    On Error GoTo CLEANUP_ON_ERROR
+
+    ' CSVを一時シートに読み込み（Power Query）
+    If Not ImportCsvToTempSheet(fpath, CSV_ENCODING, wsTemp) Then
+        Err.Raise vbObjectError + 101, , "CSVの取り込みに失敗しました。"
+    End If
+
+    ' 使用範囲特定
+    Dim lastRow As Long, lastCol As Long
+    lastRow = GetLastRow(wsTemp)
+    lastCol = GetLastCol(wsTemp)
+    If lastCol = 0 Or lastRow = 0 Then
+        Err.Raise vbObjectError + 102, , "CSVが空のようです。"
+    End If
+
+    Application.ScreenUpdating = False
+    Application.EnableEvents = False
+
+    ' ターゲットシートをクリア
+    wsTarget.Cells.Clear
+
+    ' ------- 1) ヘッダ処理（列挙メタはセル内に含まれていれば検知） -------
+    Dim colHasEnum() As Boolean
+    Dim colEnumList() As String
+    ReDim colHasEnum(1 To lastCol)
+    ReDim colEnumList(1 To lastCol)
+
+    Dim c As Long
+    For c = 1 To lastCol
+        Dim headerRaw As String
+        headerRaw = Nz(wsTemp.Cells(1, c).Value, "")
+
+        ' ヘッダはそのまま出力（列挙メタ文字列も残す）
+        wsTarget.Cells(1, c).Value = headerRaw
+
+        ' ヘッダに列挙メタ [n:ラベル] が1つでも含まれていれば検知
+        If ContainsEnumeration(headerRaw) Then
+            colHasEnum(c) = True
+            ' ヘッダ全体から [n:ラベル] を抽出し、DV用のCSV文字列を構築
+            colEnumList(c) = BuildValidationListFromEnum(headerRaw, DV_USE_CODE_ONLY)
+        Else
+            colHasEnum(c) = False
+            colEnumList(c) = ""
+        End If
+    Next c
+
+    ' ------- 2) データの貼付（CSV 2行目→Excel 2行目） -------
+    Dim tgtDataStartRow As Long: tgtDataStartRow = 2
+    Dim tgtLastRow As Long: tgtLastRow = 1
+
+    If lastRow >= 2 Then
+        Dim dataRowCount As Long
+        dataRowCount = lastRow - 1 ' 1行目はヘッダ
+        wsTemp.Range(wsTemp.Cells(2, 1), wsTemp.Cells(lastRow, lastCol)).Copy
+        wsTarget.Cells(tgtDataStartRow, 1).PasteSpecial xlPasteValues
+        tgtLastRow = tgtDataStartRow + dataRowCount - 1
+    Else
+        tgtLastRow = 1 ' データ無し
+    End If
+
+    ' ------- 3) ドロップダウン（入力規則）設定 -------
+    Dim applyToLast As Long
+    applyToLast = IIf(tgtLastRow >= 2, tgtLastRow, APPLY_DV_TO_ROW)
+
+    For c = 1 To lastCol
+        If colHasEnum(c) And Len(colEnumList(c)) > 0 Then
+            Dim dvRange As Range
+            Set dvRange = wsTarget.Range(wsTarget.Cells(2, c), wsTarget.Cells(applyToLast, c))
+            ApplyValidationList dvRange, colEnumList(c)
+        End If
+    Next c
+
+    ' ------- 4) 調整（見やすく） -------
+    wsTarget.Columns("A:" & ColLetter(lastCol)).AutoFit
+
+    Application.CutCopyMode = False
+    Application.ScreenUpdating = True
+    Application.EnableEvents = True
+
+    ' 一時シート削除
+    Application.DisplayAlerts = False
+    wsTemp.Delete
+    Application.DisplayAlerts = True
+    Exit Sub
+
+CLEANUP_ON_ERROR:
+    Application.CutCopyMode = False
+    Application.ScreenUpdating = True
+    Application.EnableEvents = True
+    On Error Resume Next
+    Application.DisplayAlerts = False
+    If Not wsTemp Is Nothing Then wsTemp.Delete
+    Application.DisplayAlerts = True
+    On Error GoTo 0
+    MsgBox "エラー: " & Err.Description, vbExclamation
+End Sub
+
+'========================================================
+' 出力シート名をファイル名から生成（長すぎる・使用不可文字は除去）
+'========================================================
+Private Function BuildOutputSheetName(ByVal fpath As String) As String
+    Dim fname As String
+    fname = fpath
+    Dim i As Long
+
+    ' パスからファイル名抽出
+    For i = Len(fpath) To 1 Step -1
+        If Mid$(fpath, i, 1) = "\" Or Mid$(fpath, i, 1) = "/" Then
+            fname = Mid$(fpath, i + 1)
+            Exit For
+        End If
+    Next i
+
+    ' 拡張子除去
+    Dim dotPos As Long
+    dotPos = InStrRev(fname, ".")
+    If dotPos > 1 Then fname = Left$(fname, dotPos - 1)
+
+    ' シート名禁止文字の除去 / の代替
+    fname = Replace(fname, ":", " ")
+    fname = Replace(fname, "/", " ")
+    fname = Replace(fname, "\", " ")
+    fname = Replace(fname, "?", " ")
+    fname = Replace(fname, "*", " ")
+    fname = Replace(fname, "[", " ")
+    fname = Replace(fname, "]", " ")
+
+    ' タイムスタンプ付与
+    BuildOutputSheetName = SHEET_NAME_PREFIX & fname & "_" & Format(Now, "yymmdd_hhnnss")
+    ' 31文字制限対応（必要なら切り詰め）
+    If Len(BuildOutputSheetName) > 31 Then
+        BuildOutputSheetName = Left$(BuildOutputSheetName, 31)
+    End If
+End Function
+
+'========================================================
+' シート名の一意化
+'========================================================
+Private Function GetUniqueSheetName(ByVal baseName As String) As String
+    Dim nameTry As String, n As Long
+    nameTry = baseName
+    n = 1
+    Do While SheetExists(nameTry)
+        n = n + 1
+        nameTry = Left$(baseName, 28) & "_" & CStr(n) ' 31文字制限に配慮
+    Loop
+    GetUniqueSheetName = nameTry
+End Function
+
+'========================================================
+' ファイルダイアログでCSVファイルを取得
+'========================================================
+Private Function PickCsvFilePath() As String
+    Dim fd As FileDialog
+    Set fd = Application.FileDialog(msoFileDialogFilePicker)
+
+    With fd
+        .Title = "CSVファイルを選択"
+        .Filters.Clear
+        .Filters.Add "CSV ファイル", "*.csv", 1
+        .AllowMultiSelect = False
+        If .Show = -1 Then
+            PickCsvFilePath = .SelectedItems(1)
+        Else
+            PickCsvFilePath = ""
+        End If
+    End With
+End Function
+
+'========================================================
+' 一時シート名をユニーク化
+'========================================================
+Private Function GetUniqueTempSheetName(ByVal baseName As String) As String
+    Dim n As Long
+    Dim nameTry As String
+    n = 0
+    Do
+        n = n + 1
+        nameTry = baseName & "_" & Format(Now, "yymmdd_hhnnss") & "_" & n
+        If SheetExists(nameTry) = False Then
+            GetUniqueTempSheetName = nameTry
+            Exit Do
+        End If
+    Loop
+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
+
+'========================================================
+' CSVを一時シートに読み込み（Power Query エンジン版）
+' encoding: "auto" | "utf8" | "cp932"
+'========================================================
+Private Function ImportCsvToTempSheet(ByVal fpath As String, ByVal encoding As String, ByVal wsTemp As Worksheet) As Boolean
+    On Error GoTo ERRH
+    wsTemp.Cells.Clear
+
+    Dim encCode As Long
+    Select Case LCase$(encoding)
+        Case "utf8":  encCode = 65001
+        Case "cp932": encCode = 932
+        Case Else:    encCode = 65001   ' autoはまずUTF-8で試行→失敗時に932で再試行
+    End Select
+
+    If ImportCsvViaPowerQuery(fpath, encCode, wsTemp) Then
+        ImportCsvToTempSheet = True
+        Exit Function
+    End If
+
+    ' autoのときはフォールバック（UTF-8失敗→CP932）
+    If LCase$(encoding) = "auto" Then
+        If ImportCsvViaPowerQuery(fpath, 932, wsTemp) Then
+            ImportCsvToTempSheet = True
+            Exit Function
+        End If
+    End If
+
+    ImportCsvToTempSheet = False
+    Exit Function
+ERRH:
+    ImportCsvToTempSheet = False
+End Function
+
+Private Function ImportCsvViaPowerQuery(ByVal fpath As String, ByVal encCode As Long, ByVal wsTemp As Worksheet) As Boolean
+    On Error GoTo ERRH
+
+    ' クエリ名をユニークに
+    Randomize
+    Dim pqName As String
+    pqName = "PQ_CSV_" & Format(Now, "yymmdd_hhnnss_") & CStr(Int(Rnd() * 100000))
+
+    ' --- Power Query (M) 式を定義 ---
+    Dim m As String
+    
+    
+    m = _
+    "let" & vbCrLf & _
+    "  Source = Csv.Document(File.Contents(""" & Replace(fpath, """", """""") & """)," & _
+    "   [Delimiter="","", Columns=null, Encoding=" & CStr(encCode) & ", QuoteStyle=QuoteStyle.Csv])," & vbCrLf & _
+    "  Promote = Table.PromoteHeaders(Source, [PromoteAllScalars=true])," & vbCrLf & _
+    "  AsText  = Table.TransformColumnTypes(Promote, List.Transform(Table.ColumnNames(Promote), each {_, type text}))," & vbCrLf & _
+    "  AllCols = Table.ColumnNames(AsText)," & vbCrLf & _
+    "  // ""Column1"" のような自動列名 かつ 列内の全値が Null または 空白のみ なら削除対象にする" & vbCrLf & _
+    "  Trim = (v as any) as text => Text.Trim(Text.From(v, Culture=null))," & vbCrLf & _
+    "  IsEmptyCol = (tbl as table, col as text) as logical =>" & vbCrLf & _
+    "    List.AllTrue(List.Transform(Table.Column(tbl, col), (v) => v = null or Trim(v) = """" ))," & vbCrLf & _
+    "  ToRemove = List.Select(AllCols, (cn) => Text.StartsWith(cn, ""Column"") and IsEmptyCol(AsText, cn))," & vbCrLf & _
+    "  Cleaned = if List.Count(ToRemove) > 0 then Table.RemoveColumns(AsText, ToRemove) else AsText" & vbCrLf & _
+    "in" & vbCrLf & _
+    "  Cleaned"
+
+    ' 既存の内容を一旦クリア
+    wsTemp.Cells.Clear
+
+    ' --- クエリの追加（ブック内に定義） ---
+    Dim q As WorkbookQuery
+    Set q = ThisWorkbook.Queries.Add(Name:=pqName, Formula:=m)
+
+    ' --- OLEDB 接続文字列（Power Query への橋渡し） ---
+    Dim connStr As String
+    connStr = "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & pqName & ";Extended Properties="""""
+
+    ' --- QueryTable を使ってシートにロード（SQL 明示）---
+    Dim qt As QueryTable
+    Set qt = wsTemp.QueryTables.Add(Connection:=connStr, Destination:=wsTemp.Range("A1"))
+    With qt
+        .CommandType = xlCmdSql
+        .CommandText = "SELECT * FROM [" & pqName & "]"
+        .PreserveFormatting = True
+        .AdjustColumnWidth = False
+        .RefreshStyle = xlOverwriteCells
+        .BackgroundQuery = False
+        .Refresh ' ← ここで実行
+    End With
+
+    ' 値として固定（再解釈を防ぐ）
+    wsTemp.UsedRange.Value = wsTemp.UsedRange.Value
+
+    ' --- 後片付け（接続・クエリの削除） ---
+    On Error Resume Next
+    Dim cn As WorkbookConnection
+    For Each cn In ThisWorkbook.Connections
+        If InStr(1, cn.Name, pqName, vbTextCompare) > 0 Then cn.Delete
+        If Not cn.OLEDBConnection Is Nothing Then
+            If InStr(1, cn.OLEDBConnection.Connection, "Location=" & pqName, vbTextCompare) > 0 Then cn.Delete
+        End If
+    Next
+    ThisWorkbook.Queries(pqName).Delete
+    On Error GoTo 0
+
+    ImportCsvViaPowerQuery = True
+    Exit Function
+
+ERRH:
+    ' クリーンアップ
+    On Error Resume Next
+    Dim cn2 As WorkbookConnection
+    For Each cn2 In ThisWorkbook.Connections
+        If InStr(1, cn2.Name, pqName, vbTextCompare) > 0 Then cn2.Delete
+        If Not cn2.OLEDBConnection Is Nothing Then
+            If InStr(1, cn2.OLEDBConnection.Connection, "Location=" & pqName, vbTextCompare) > 0 Then cn2.Delete
+        End If
+    Next
+    ThisWorkbook.Queries(pqName).Delete
+    On Error GoTo 0
+
+    ImportCsvViaPowerQuery = False
+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 If
+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 If
+End Function
+
+'========================================================
+' ヘッダ文字列の中に [n:ラベル] パターンが含まれるか判定（改行不問）
+'========================================================
+Private Function ContainsEnumeration(ByVal s As String) As Boolean
+    Dim re As Object
+    Set re = CreateObject("VBScript.RegExp")
+    re.Pattern = "\[\d+:[^\]]+\]"
+    re.IgnoreCase = True
+    re.Global = True
+    ContainsEnumeration = re.Test(s)
+End Function
+
+'========================================================
+' ヘッダ全体から [n:ラベル] を抽出して、入力規則のリスト文字列を生成
+' DV_USE_CODE_ONLY=False: "0:無効,1:有効"
+' DV_USE_CODE_ONLY=True : "0,1"
+'========================================================
+Private Function BuildValidationListFromEnum(ByVal s As String, ByVal codeOnly As Boolean) As String
+    Dim re As Object, mc As Object, m As Object
+    Set re = CreateObject("VBScript.RegExp")
+    re.Pattern = "\[(\d+):([^\]]+)\]"
+    re.IgnoreCase = True
+    re.Global = True
+
+    Dim parts As Collection
+    Set parts = New Collection
+
+    If re.Test(s) Then
+        Set mc = re.Execute(s)
+        Dim code As String, label As String
+        For Each m In mc
+            code = m.SubMatches(0)
+            label = m.SubMatches(1)
+            If codeOnly Then
+                parts.Add code
+            Else
+                parts.Add code & ":" & label
+            End If
+        Next m
+    End If
+
+    Dim i As Long, buf As String
+    For i = 1 To parts.count
+        buf = buf & IIf(Len(buf) > 0, ",", "") & CStr(parts(i))
+    Next i
+
+    BuildValidationListFromEnum = buf
+End Function
+
+'========================================================
+' 入力規則（リスト）を範囲に適用
+'========================================================
+Private Sub ApplyValidationList(ByVal rng As Range, ByVal listCsv As String)
+    On Error Resume Next
+    rng.Validation.Delete
+    On Error GoTo 0
+
+    If Len(listCsv) = 0 Then Exit Sub
+
+    With rng.Validation
+        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, _
+             Formula1:=listCsv
+        .IgnoreBlank = True
+        .InCellDropdown = True
+        .ErrorTitle = "入力値エラー"
+        .ErrorMessage = "リストから選択してください。"
+        .ShowError = True
+    End With
+End Sub
+
+'========================================================
+' Null/Emptyを空文字にする補助
+'========================================================
+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 ColLetter(ByVal colNum As Long) As String
+    Dim s As String
+    Do While colNum > 0
+        s = Chr(((colNum - 1) Mod 26) + 65) & s
+        colNum = (colNum - 1) \ 26
+    Loop
+    ColLetter = s
+End Function
+
+