【VBA】CSV分割&整形ツール


概要

CSVファイルをExcelに読み込ませて、任意の列のセル書式を「文字列」に変換するVBA。

また、任意の列をグループごとにデータ分割し、それぞれのデータをシート別に出力する。


使い方

下のようなExcelシートを用意します。

image.png

各ボタンにマクロを登録します。

上から順に。。。

'CSV分割&整形ツール.xlsm'!'readCsv False'

'CSV分割&整形ツール.xlsm'!'deleteSheet False,True'

'CSV分割&整形ツール.xlsm'!'deleteSheet False,False'

'CSV分割&整形ツール.xlsm'!'divideCsv False'

'CSV分割&整形ツール.xlsm'!'divideCsv True'

'CSV分割&整形ツール.xlsm'!exportFiles

マニュアル、設定マスタシートも作成します。

マニュアルシートは今回は白紙とします。

設定マスタシートは↓のように作ってください。

image.png

A列の「文字列出力項目名」は、セル書式を文字列にする列名を記入。

B列の「分割項目名」は、グループ単位で分割したい列名を記入。

C列の「分割パラメータリスト」は、B列の「分割項目名」で指定した列のうち、分割対象のパラメータを記入。

記入されたパラメータに合致するグループのみ分割して、新規シートに転記します。


動作後イメージ

5.CSV読込&データ分割ボタン押下後

「シート一覧」に生成されたシートへのリンクが作成されます。

image.png

設定マスタの「文字列出力項目名」に記入されていた「項目5」列が文字列として出力されています。

image.png

設定マスタの「分割パラメータリスト」に記入されていた各パラメータに合致するデータのみ、データ分割&シートに転記されています。

image.png


ソース


CSV分割&整形ツール.xlsm

'=======================================================================

'
' File Name : CSV分割&整形ツール.xlsm
' Creation Date : 2019/04/03
'
' Copyright (c) 2019 irohamaru. All rights reserved.
'
' This source code or any portion thereof must not be
' reproduced or used in any manner whatsoever.
'
'=======================================================================

Option Private Module

Dim openFilePath As String '読込CSVファイルパス
Dim headerList As Variant '読込CSVヘッダー
Dim readCsvResult As Boolean '0: エラー(デフォルト), 1:正常終了, 2:既に読込済
Const adOpenKeyset = 1
Const adLockReadOnly = 1
Const MAINSHEETNAME As String = "メイン" 'メインシート名
Const MANUALSHEETNAME As String = "マニュアル" 'マニュアルシート名
Const SETSHEETNAME As String = "設定マスタ" '設定マスタシート名
Const CONVLISTCOL As String = "A" '文字列出力項目名_列
Const DIVLISTCOL As String = "B" '分割項目名_列
Const DIVPARAMLISTCOL As String = "C" '分割項目パラメータ_列
Const SHEETLISTCOL As String = "H" 'シート一覧列
Const HEADERROW As Integer = 2 'シート一覧ヘッダーセル行番号
Const PREFIX As String = "【Excel変換】" '出力ファイル接頭語
Const CSVEXT As String = ".csv" 'CSV拡張子
Const THRESHOLD As Integer = 100 '分割数アラート閾値

' CSVファイル読込
Sub readCsv(callFromDivideCsv)
On Error Resume Next

On Error GoTo readCsvErr1

readCsvResult = 0

Dim mainSheet As Worksheet
Set mainSheet = Worksheets(MAINSHEETNAME)

openFilePath = selectFile

' CSVの項目数
Dim columnCount As Integer: columnCount = 0

If openFilePath = "False" Then
MsgBox "読み込むファイルを選択してください。" & vbCrLf & _
"処理を終了します。", vbExclamation
GoTo readCsvErr1
Else
' CSVの項目一覧、項目数を取得
Dim buf As String
Open openFilePath For Input As #1
Do Until EOF(1)
Line Input #1, buf
headerList = Split(buf, ",")
columnCount = UBound(headerList)
Exit Do
Loop
Close #1
End If

Dim fileName As String
Dim csvFileCount As Integer: csvFileCount = 0
' シート名は31文字以内
fileName = makeBaseCsvSheetName()
For Each sh In Worksheets
If InStr(sh.Name, CSVEXT) > 0 Then
csvFileCount = csvFileCount + 1
End If
If sh.Name = fileName Then
If callFromDivideCsv = False Then
MsgBox "同名のファイルが既に読み込まれています。" & vbCrLf & _
"「シートを全削除」ボタンをクリックし、" & _
"シート削除後再度実行してください。", vbExclamation
End If
readCsvResult = 2
GoTo readCsvErr1
End If
Next
If csvFileCount >= 1 Then
MsgBox "複数のCSVファイルが読み込まれています。" & vbCrLf & _
"読み込むCSVファイルは1ファイルにしてください。" & vbCrLf & _
"処理を終了します。", vbExclamation
GoTo readCsvErr1
End If

On Error GoTo readCsvErr2

' シート追加
Dim wsImport As Worksheet
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = makeBaseCsvSheetName()

' CSVデータ取り込み用シート
Set wsImport = Worksheets(ActiveSheet.Name)

' 文字列出力項目名リストを取得
Dim convList As Variant
convList = getSettingList(CONVLISTCOL)
' Split(Replace(Replace(mainSheet.Range(SETTINGCOL & CONVLISTROW).Value, " ", ""), " ", ""), ",")

' 文字列セル書式設定
Dim i, j As Integer
Dim dataTypesArray() As Variant

' 各列の書式設定用配列
For i = 0 To columnCount
ReDim Preserve dataTypesArray(i)

For j = 0 To UBound(convList)
Dim strConv, strHeader As String
strHeader = CStr(headerList(i))
strConv = CStr(convList(j))

If strConv = strHeader Then
dataTypesArray(i) = xlTextFormat
End If
Next

If dataTypesArray(i) = "" Then
dataTypesArray(i) = xlGeneralFormat
End If

Next

On Error GoTo readCsvErr3

' データ読込
Dim queryTb As QueryTable
Set queryTb = wsImport.QueryTables.Add(Connection:="TEXT;" & openFilePath, _
Destination:=wsImport.Range("A1")) ' CSV を開く
With queryTb
.TextFilePlatform = 932 ' 文字コードを指定
.TextFileParseType = xlDelimited ' 区切り文字の形式
.TextFileCommaDelimiter = True ' カンマ区切り
.RefreshStyle = xlOverwriteCells ' セルに書き込む方式
.TextFileColumnDataTypes = dataTypesArray ' 各列の型を指定
.AdjustColumnWidth = False ' 列幅の自動調整False
.Refresh ' データを表示
.Delete ' CSVファイルとの接続を解除
End With

If callFromDivideCsv = False Then
' シート一覧作成
Call makeSheetList
MsgBox "CSVファイルの読込が完了しました。", vbInformation
End If

readCsvResult = 1

readCsvErr3:
Set queryTb = Nothing
readCsvErr2:
Set wsImport = Nothing
readCsvErr1:
Set mainSheet = Nothing

End Sub

' CSVデータを各シートに分割
Sub divideCsv(selectDivParam)
On Error Resume Next

On Error GoTo divideCsvErr1

Dim mainSheet, tgtSheet, newSheet As Worksheet
Set mainSheet = Worksheets(MAINSHEETNAME)

' 分割項目名リストを取得
Dim divList As Variant
Dim divColNum As Long
Dim divColName As String
divList = getSettingList(DIVLISTCOL)
' Split(Replace(Replace(mainSheet.Range(SETTINGCOL & DIVLISTROW).Value, " ", ""), " ", ""), ",")

' CSVファイル読込
Call readCsv(True)
If readCsvResult = 0 Then
GoTo divideCsvErr1
Else
Dim matchCount As Integer: matchCount = 0
Dim divCount, idx As Integer
Dim divIdxList() As Variant

If UBound(divList) = -1 Then
' シート削除&リンクをクリア
' Call deleteSheet(True, True)

MsgBox "分割項目名が設定されていません。" & vbCrLf & _
"処理を終了します。", vbExclamation

GoTo divideCsvErr1
End If

For divCount = 0 To UBound(divList)
For idx = 0 To UBound(headerList)
If divList(divCount) = headerList(idx) Then
matchCount = matchCount + 1

' 分割項目名、分割項目列設定
divColName = divList(divCount)
divColNum = idx + 1
End If
Next
Next

' 分割対象列存在チェック
If matchCount = 0 Then
' 分割項目名がCSVデータの列に存在しない場合
' シート削除&リンクをクリア
' Call deleteSheet(True, True)

MsgBox "分割項目名に設定された列名に合致する列がCSVデータ中に存在しません。" & _
vbCrLf & "処理を終了します。", vbExclamation

GoTo divideCsvErr1
ElseIf matchCount > 1 Then
' 分割項目名がCSVデータの列に複数該当する場合
' シート削除&リンクをクリア
' Call deleteSheet(True, True)
MsgBox "分割項目名に設定された列名がCSVデータ中に複数該当します。" & vbCrLf & _
"分割する列は1つのみ合致するように設定してください。" & vbCrLf & _
"処理を終了します。", vbExclamation

GoTo divideCsvErr1
End If

Set tgtSheet = Worksheets(makeBaseCsvSheetName())
tgtSheet.Activate

End If

On Error GoTo divideCsvErr2

' 接続を確立する
Dim dbCon, dbRs As Object
Set dbCon = CreateObject("ADODB.Connection")
Set dbRs = CreateObject("ADODB.Recordset")

dbCon.Provider = "Microsoft.ACE.OLEDB.12.0"
dbCon.Properties("Extended Properties") = "Excel 12.0;HDR=NO;IMEX=1"
dbCon.Open ThisWorkbook.FullName

' グループ一覧取得
Dim strGrpSQL As String
Dim grpList() As Variant
Dim cnt As Integer: cnt = 0

If selectDivParam = True Then
' 分割パラメータリストを取得
Dim divParamList As Variant
divParamList = getSettingList(DIVPARAMLISTCOL)

If UBound(divParamList) = -1 Then

MsgBox "分割パラメータリストが設定されていません。" & vbCrLf & _
"処理を終了します。", vbExclamation

' シート削除&リンクをクリア
' Call deleteSheet(True, True)

GoTo divideCsvErr2
Else

For Each d In divParamList
If d <> "" Then
ReDim Preserve grpList(cnt)
grpList(cnt) = d
cnt = cnt + 1
End If
Next

End If

Else
strGrpSQL = ""
strGrpSQL = strGrpSQL & " SELECT " & "F" & divColNum & " FROM [" & tgtSheet.Name & "$] "
strGrpSQL = strGrpSQL & " GROUP BY " & "F" & divColNum

dbRs.Open strGrpSQL, dbCon, adOpenKeyset, adLockReadOnly

Do Until dbRs.EOF
If divColName = dbRs.Fields(0).Value Then GoTo Continue
ReDim Preserve grpList(cnt)
' シート名は31文字以内
grpList(cnt) = Left(dbRs.Fields(0).Value, 31)
cnt = cnt + 1
Continue:
dbRs.MoveNext
Loop

dbRs.Close

End If

If UBound(grpList) >= THRESHOLD Then
Dim rs As Integer
rs = MsgBox("データ分割により、シートを" & UBound(grpList) & "作成します。" & vbCrLf & _
"分割パラメータを指定することを推奨します。" & vbCrLf & _
"処理を続行しますか?", vbYesNo + vbExclamation, "確認")

' 続行しない場合は処理終了
If rs = vbNo Then
GoTo divideCsvErr2
End If

End If

Dim strSQL As String

' グループ分シート生成&データ貼り付け
Dim i As Integer
For i = 0 To UBound(grpList)
Dim grpListStr As String
grpListStr = CStr(grpList(i))

strSQL = ""
strSQL = strSQL & " SELECT * FROM [" & tgtSheet.Name & "$] "
strSQL = strSQL & " WHERE " & "F" & divColNum & " = '" & grpListStr & "'"
dbRs.Open strSQL, dbCon, adOpenKeyset, adLockReadOnly

' シート追加
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = grpListStr
Set newSheet = Worksheets(grpListStr)
' ヘッダー追加
Dim columnCount As Integer
columnCount = UBound(headerList)
Dim j As Integer
For j = 0 To columnCount
newSheet.Cells(1, j + 1) = headerList(j)
Next
newSheet.Range("A2").CopyFromRecordset dbRs
dbRs.Close

' 列幅自動調整
' newSheet.Range(Columns(1), Columns(columnCount)).EntireColumn.AutoFit

Next

' シート一覧作成
Call makeSheetList

' メインシートを選択
mainSheet.Activate
mainSheet.Range("A1").Select

MsgBox "CSVデータを各シートに分割しました。" & vbCrLf & _
"処理を終了します。", vbInformation

divideCsvErr2:
Set dbRs = Nothing
dbCon.Close
Set dbCon = Nothing
divideCsvErr1:
Set newSheet = Nothing
Set tgtSheet = Nothing
Set mainSheet = Nothing

End Sub

' シート削除
Sub deleteSheet(callFromDivideCsv, deleteBaseCsv)
On Error Resume Next

On Error GoTo deleteSheetErr

Dim mainSheet As Worksheet
Set mainSheet = Worksheets(MAINSHEETNAME)

Application.DisplayAlerts = False

' リンクをクリア
Call deleteLink(mainSheet, deleteBaseCsv)

' シート削除
For Each sh In Worksheets
If sh.Name <> MAINSHEETNAME And _
sh.Name <> MANUALSHEETNAME And sh.Name <> SETSHEETNAME Then
If deleteBaseCsv = True Then
sh.Delete
Else
If InStr(sh.Name, CSVEXT) = 0 Then
sh.Delete
End If
End If
End If
Next

Application.DisplayAlerts = True

If callFromDivideCsv = False Then
MsgBox "メインシート以外を削除しました。" & vbCrLf & _
"処理を終了します。", vbInformation
End If

deleteSheetErr:
Set mainSheet = Nothing

End Sub

' ファイル出力
Sub exportFiles()
' メイン、マニュアル、設定マスタシート以外がない場合終了
If Worksheets.Count = 3 Then
MsgBox "出力対象のシートがないため、処理を終了します。", vbExclamation
Exit Sub
End If

' フォルダ存在チェック&作成
Dim folderPath As String
Dim createFolder As Boolean
For Each sh In Worksheets
If InStr(sh.Name, CSVEXT) > 0 Then
folderPath = ThisWorkbook.Path & "\" & PREFIX & Replace(sh.Name, CSVEXT, "")
If Dir(folderPath, vbDirectory) = "" Then
' 保存先フォルダ作成
MkDir folderPath
createFolder = True
Else
' 同名のフォルダが既に存在している場合終了
MsgBox folderPath & vbCrLf & _
"が既に存在するため、処理を終了します。", vbExclamation
Exit Sub
End If
End If
Next
If createFolder = False Then
MsgBox "分割元のCSVファイルの内容が記載されたシートが見つかりませんでした。" & vbCrLf & _
"処理を終了します。", vbExclamation
Exit Sub
End If

For Each sh In Worksheets
Dim fileName As String
If sh.Name <> MAINSHEETNAME And _
sh.Name <> MANUALSHEETNAME And sh.Name <> SETSHEETNAME Then
If InStr(sh.Name, CSVEXT) > 0 Then
fileName = PREFIX & Replace(sh.Name, CSVEXT, "")
Else
fileName = sh.Name
End If
sh.Copy
ActiveWorkbook.SaveAs folderPath & "\" & fileName
ActiveWorkbook.Close
End If
Next

MsgBox folderPath & vbCrLf & _
"にファイルを出力しました。" & vbCrLf & _
"処理を終了します。", vbInformation

End Sub

' 読込ファイル選択
Function selectFile()
'読み込むファイル
selectFile = Application.GetOpenFilename("CSVファイル,*.csv")

End Function

' 設定マスタリストを取得
Function getSettingList(col)
Dim setMstSheet As Worksheet
Set setMstSheet = Worksheets(SETSHEETNAME)

Dim returnList As Variant
returnList = Array()

With setMstSheet
If .Range(col & 2).Value <> "" Then
Dim maxRow, i As Integer
maxRow = .Range(col & 1).End(xlDown).Row

For i = 2 To maxRow
ReDim Preserve returnList(i - 2)
returnList(i - 2) = .Range(col & i).Value
Next
End If
End With

Set setMstSheet = Nothing

getSettingList = returnList

End Function

' 分割元CSVファイル設定
Function makeBaseCsvSheetName()
If InStr(Left(Dir(openFilePath), 31), CSVEXT) > 1 Then
makeBaseCsvSheetName = Left(Dir(openFilePath), 31)
Else
makeBaseCsvSheetName = Left(Dir(openFilePath), 27) & CSVEXT
End If
End Function

' シートリストを作成
Private Sub makeSheetList()
On Error Resume Next

On Error GoTo makeSheetListErr

Dim mainSheet As Worksheet
Set mainSheet = Worksheets(MAINSHEETNAME)

' リンクをクリア
Call deleteLink(mainSheet, True)

' リンクを作成
Dim j, k As Integer: k = 1
For j = 1 To Worksheets.Count
If Worksheets(j).Name <> MAINSHEETNAME And _
Worksheets(j).Name <> MANUALSHEETNAME And _
Worksheets(j).Name <> SETSHEETNAME Then
mainSheet.Hyperlinks.Add Anchor:=mainSheet.Range(SHEETLISTCOL & HEADERROW + k), _
Address:="", _
SubAddress:="'" & Worksheets(j).Name & "'" & "!A1", _
TextToDisplay:=Worksheets(j).Name
k = k + 1
End If
Next

' 左寄せ
mainSheet.Range(SHEETLISTCOL & ":" & SHEETLISTCOL).HorizontalAlignment = xlLeft
' 列幅自動調整
mainSheet.Columns(SHEETLISTCOL & ":" & SHEETLISTCOL).AutoFit

makeSheetListErr:
Set mainSheet = Nothing

End Sub

' リンクをクリア
Private Sub deleteLink(sh, deleteBaseCsv)
Dim maxRow As Integer: maxRow = HEADERROW

' シート一覧に1つ以上記入がある場合のみ処理
If sh.Range(SHEETLISTCOL & HEADERROW + 1).Value <> "" Then
maxRow = sh.Range(SHEETLISTCOL & HEADERROW).End(xlDown).Row

Dim linkStr As String
Dim i As Integer
For i = HEADERROW + 1 To maxRow
linkStr = sh.Range(SHEETLISTCOL & i).Value
If deleteBaseCsv = False And InStr(linkStr, CSVEXT) > 0 Then
' 分割元CSVデータシートを削除しない場合、リンクも削除しない
Else
sh.Range(SHEETLISTCOL & i).Value = ""
End If
Next

' 列幅自動調整
sh.Columns(SHEETLISTCOL & ":" & SHEETLISTCOL).AutoFit

End If

' セル選択
sh.Activate
sh.Range("A1").Select

End Sub