概要
1. csv一覧のあるフォルダを選択する
2. フォルダからcsv一覧を取得してファイル名でソート（Qソート）する
3. csvデータ変換用テンプレート一覧をシートから読み込む
4. UserFormを使用してテンプレート選択フォームを表示して使用する変換テンプレートを選択する
5. テンプレートに従ってcsvファイルを順にexcel（新しいworkbook）に変換しながらコピーする
※勢いで作成したので別途リファクタリングが必要
必要な参照設定
Microsoft VBScript Regular Expressions 5.5
Microsoft Scripting Runtime
csvデータ変換用テンプレート
[ConvertTemplateシート]
(変更方法説明）
作成するフォーム/標準モジュール/クラスモジュール
[標準モジュール]
Main
[フォーム]
SelectTemplateForm
[クラスモジュール]
ConvertCsv
CsvConvertTemplateReader
FileFinder
ValueConverter
標準モジュール
[Main]
Option Explicit
'一連の処理を実行する
Public Sub Main()
'テンプレートシート名
Const templateSheetName = "ConvertTemplate"
Dim templateSheet As Worksheet
'ファイルのあるディレクトリパス
Dim dirPath As String
'ファイル一覧
Dim fileList As Collection
Dim fileFinder As fileFinder
'変換テンプレート
Dim templateReader As CsvConvertTemplateReader
Dim templateForm As SelectTemplateForm
Dim selectedTemplate As String
Dim convertCsv As convertCsv
'汎用添え字
Dim i As Integer
'テンプレートシートを取得する
For i = 1 To Sheets.Count
If Sheets(i).name = templateSheetName Then
Set templateSheet = Sheets(i)
Exit For
End If
Next
If templateSheet Is Nothing Then
MsgBox templateSheetName & "シートがありません。処理をを中断します", vbOKOnly, "終了"
Exit Sub
End If
'テンプレートを読み込む
Set templateReader = New CsvConvertTemplateReader
Call templateReader.ReadTemplae(templateSheet)
'データのあるフォルダを選択する
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 1 Then
dirPath = .SelectedItems(1)
Else
MsgBox "処理を中断します", vbOKOnly, "終了"
Exit Sub
End If
End With
'ファイル一覧を取得する
Set fileFinder = New fileFinder
fileFinder.SetFileNameFilter ("^.*\.csv$")
Set fileList = fileFinder.CollectFile(dirPath)
If fileList.Count = 0 Then
MsgBox "ファイルがありません", vbOKOnly, "終了"
End If
'テンプレートを選択する
Set templateForm = New SelectTemplateForm
Call templateForm.setTemplateNemaList(templateReader.getTemplateNameList())
Call templateForm.Show
If Not (templateForm.IsOk()) Then
MsgBox "処理を中断します", vbOKOnly, "終了"
Exit Sub
End If
selectedTemplate = templateForm.result
'データ変換
Set convertCsv = New convertCsv
Call convertCsv.Convert(dirPath, fileList, templateReader.getTemplate(selectedTemplate))
End Sub
クラスモジュール
[ConvertCsv]
'
'CSVファイルを読み込んでEXCELに出力する
'
'
'
Option Explicit
Dim csvTemplate As Dictionary
'
'CSVファイルを読み込む
'
'@param dirPath ディレクトリパス
'@param csvFiles CSVファイル一覧
'@param template 変換テンプレート
'
'
Public Sub Convert(dirPath As String, csvFileList As Collection, template As Dictionary)
Dim book As Workbook
Dim sheet As Worksheet
Dim fileName As Variant
Dim rowIdx As Integer
Set book = Workbooks.Add
Set sheet = book.Sheets.Add
sheet.name = "Data"
Set csvTemplate = template
rowIdx = 1
For Each fileName In csvFileList
Call CsvToWorkSheet(rowIdx, sheet, dirPath & "\" & fileName)
Next
End Sub
'
'CSVファイルをExcelに出力する
'
'@param rowIdx 行番号
'@param sheet データ出力先のシート
'@param filePath CSVファイルパス
'
'
Private Sub CsvToWorkSheet(ByRef rowIdx As Integer, sheet As Worksheet, csvFilePath As String)
Dim conv As ValueConverter
Dim hfile As Integer
Dim csv As String
Dim csvArray As Variant
Dim i As Integer
Dim j As Integer
Dim str As String
Dim keys
keys = csvTemplate.keys
Set conv = New ValueConverter
j = 0
Application.ScreenUpdating = False
Open csvFilePath For Input As #1
Do Until EOF(1)
Line Input #1, csv
If Len(Trim(csv)) > 0 Then
If rowIdx = 1 Then
csvArray = Split(csv, ",")
For i = 0 To UBound(keys)
sheet.Cells(rowIdx, i + 1).value = csvArray(keys(i))
Next
rowIdx = rowIdx + 1
ElseIf j > 0 And rowIdx > 1 Then
csvArray = Split(csv, ",")
For i = 0 To UBound(keys)
str = csvArray(keys(i))
Call conv.ConvertAndSet(sheet.Cells(rowIdx, i + 1), csvTemplate(keys(i)), str)
Next
rowIdx = rowIdx + 1
End If
End If
j = j + 1
Loop
Close #1
Application.ScreenUpdating = True
End Sub
[CsvConvertTemplateReader]
'
' データ変換用テンプレートクラス
'
'
'
Option Explicit
Private templateList As Dictionary
'
'テンプレートを読み込む
'
'
'@param templateName テンプレート名
'@param templateSheet テンプレートシート
'
Public Sub ReadTemplae(templateSheet As Worksheet)
Dim emptyCount As Integer '空行が5行継続した場合はデータの終了と判断する
Dim rowIdx As Integer
Dim colIdx As Integer
Dim templateName As String
Dim template As Dictionary
Set templateList = New Dictionary
' テンプレートを読み込む
emptyCount = 0
rowIdx = 2
Do
templateName = Trim(templateSheet.Cells(rowIdx, 1))
If Len(templateName) = 0 Then
'空行
If emptyCount >= 5 Then
Exit Do
End If
emptyCount = emptyCount + 1
rowIdx = rowIdx + 1
Else
emptyCount = 0
Set template = New Dictionary
colIdx = 2
Do
If Len(Trim(templateSheet.Cells(rowIdx, colIdx))) = 0 Then
Exit Do
End If
'1行目：CSVの列番号
'2行目：変換形式
template.Add templateSheet.Cells(rowIdx, colIdx), templateSheet.Cells(rowIdx + 1, colIdx)
colIdx = colIdx + 1
Loop
If template.Count > 0 Then
templateList.Add templateName, template
End If
rowIdx = rowIdx + 2
End If
Loop
End Sub
'
'テンプレート名一覧を取得する
'
'@return テンプレート名
'
Public Function getTemplateNameList() As Collection
Dim result As Collection
Dim key As Variant
Set result = New Collection
For Each key In templateList.keys
result.Add key
Next
Set getTemplateNameList = result
End Function
'
'テンプレート数を取得する
'
'@return テンプレート数
'
Public Function Count() As Integer
Count = templateList.Count
End Function
'
'テンプレートを取得する
'
'@param テンプレート名
'@return テンプレート
'
Public Function getTemplate(templateName As String) As Dictionary
Set getTemplate = templateList(templateName)
End Function
'
'テンプレートが存在するかチェックする
'
'@param templateName テンプレート名
'@return テンプレートが存在している場合はTrue、それ以外はFalse
'
Public Function Exists(templateName As String) As Boolean
If templateList.Exists(templateName) Then
Exists = True
End If
Exists = False
End Function
[FileFinder]
'
'指定されたフォルダからファイル一覧を検索する
'
'必要な参照設定：
' Microsoft VBScript Regular Expressions 5.5
' Microsoft Scripting Runtime
Option Explicit
' フィルタ（完全一致）
Private filter As RegExp
Private hasFilter As Boolean
Private Sub Class_Initialize()
hasFilter = False
End Sub
'
'特定のフォルダからファイル名を検索する
'
'@param directoryPath ディレクトリパス
'@return ファイル名一覧（パスなし）
'
Public Function CollectFile(directoryPath As String) As Collection
Dim fso As FileSystemObject
Dim f As File
Dim Count As Integer
Dim result As Collection
Set fso = New FileSystemObject
Set result = New Collection
'ファイル一覧取得
Dim dir As Folder
Set dir = fso.GetFolder(directoryPath)
For Each f In dir.Files
If IsMatch(f.name) Then
result.Add f.name
End If
Next
'
If result.Count > 0 Then
Call Sort(result, 1, result.Count)
End If
Set CollectFile = result
End Function
'
'配列を昇順ソートする（クリックソート）
'
'@param value 配列
'@return ソート後の配列
'
Private Function Sort(ByRef values As Collection, low As Integer, high As Integer) As Collection
Dim iLow As Integer
Dim iHigh As Integer
Dim tmp As String
Dim center As String
iLow = low
iHigh = high
' 中央値を取得
center = values(Int((iLow + iHigh) / 2))
Do
'左側検索
Do
If values(iLow) >= center Then
Exit Do
End If
iLow = iLow + 1
Loop
'右側検索
Do
If center >= values(iHigh) Then
Exit Do
End If
iHigh = iHigh - 1
Loop
If iLow >= iHigh Then
Exit Do
End If
'入れ替え
tmp = values(iLow)
values(iLow) = iHigh
values(iHigh) = tmp
Loop
'中央値よりも小さいグループのソート
If low < iLow - 1 Then
Call Sort(values, low, iLow - 1)
End If
'中央値よりも大きいグループのソート
If iHigh + 1 < high Then
Call Sort(values, iHigh + 1, high)
End If
End Function
'
' ファイル名フィルタを設定する
'
' @param pattern フィルタパターン（正規表現）
'
Public Function SetFileNameFilter(pattern As String)
Set filter = New RegExp
'適合パターンの設定
filter.pattern = pattern
'全角/半角を区別する
filter.IgnoreCase = True
'検索文字列全体について検索する
filter.Global = True
hasFilter = True
End Function
'
'フィルタに適合するかチェックする
'
'@param fileName ファイル名
'
Private Function IsMatch(fileName As String) As Boolean
Dim result As Boolean
result = False
If hasFilter Then
result = filter.test(fileName)
Else
result = False
End If
IsMatch = result
End Function
[ValueConverter]
'
'データ変換用トクラス
'
'
'
'
'値を変換してセルに値を設定する
'
'@param range 値を設定するセル
'@param convertType 変換種別
'@param value 値
'
Public Function ConvertAndSet(range As range, convertType As String, value As String) As Variant
Select Case convertType
Case "TEXT"
Case ConvertTEXT(range, value)
Case "TIME001"
Call ConvertTIME001(range, value)
Case "NUMBER001"
Call ConvertNUMBER001(range, value)
Case Else
Call ConvertDEFAULT(range, value)
End Select
End Function
'
'EXCELに任せる
'
Private Sub ConvertDEFAULT(range As range, value As String)
range.value = value
range.NumberFormatLocal = "G/標準"
End Sub
'
'文字列に変換する
'
Private Sub ConvertTEXT(range As range, value As String)
range.value = value
range.NumberFormatLocal = "@"
End Sub
'
'数値に変換する
'
Private Sub ConvertNUMBER001(range As range, value As String)
range.value = Val(value)
range.NumberFormatLocal = "0"
End Sub
'
'yyyy-mm-dd hh:mm:ss → yyyy/mm/dd hh:mm:ss に変換する
'
Private Sub ConvertTIME001(range As range, value As String)
Dim reg As RegExp
Dim convertStr As String
Dim result, subResult
Set reg = New RegExp
reg.pattern = "^(\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)$"
Set result = reg.Execute(value)
Set subResult = result(0).SubMatches
convertStr = subResult(0) & "/" & _
subResult(1) & "/" & _
subResult(2) & " " & _
subResult(3) & ":" & _
subResult(4) & ":" & _
subResult(5)
range.value = value
range.NumberFormatLocal = "yyyy/mm/dd hh:mm:ss"
End Sub
フォーム
[SelectTemplateForm]
Option Explicit
Private selectedItem As String
Private Sub UserForm_Activate()
selectedItem = ""
End Sub
'
'テンプレート一覧を設定する
'
'@param templateNameList テンプレート
'
Public Sub setTemplateNemaList(ByRef values As Collection)
Dim value As Variant
For Each value In values
templateList.AddItem value
Next
End Sub
'
'結果を取得する
'
Public Function result() As String
result = selectedItem
End Function
'
'結果を取得する（決定 or キャンセル）
'
Public Function IsOk() As Boolean
IsOk = Len(result) > 0
End Function
'
'決定
'
Private Sub btnOk_Click()
If Len(templateList.value) > 0 Then
selectedItem = templateList.value
Hide
Else
MsgBox "テンプレートを選択してください", vbOKOnly, "確認"
End If
End Sub
'
'キャンセル
'
Private Sub btnCancel_Click()
selectedItem = ""
Call Hide
End Sub
'
'×ボタンを無効にする
'
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Cancel = True
End Sub