490 lines
17 KiB
Plaintext
490 lines
17 KiB
Plaintext
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
|
||
|
||
|