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