データ出力を伴う様々なシステムでCSVファイルが扱われています。
システム知識の浅いユーザーが手動でCSVファイルを触るとデータを破損させてしまうことが多いです。その主な原因は、Excelが文字コードや改行を勝手に変更してしまうことがあるからです。そのくせ、CSVファイルをダブルクリックするとExcelで開いてしまうので厄介です。
Cassava Editorなど、CSVファイルを崩さずに編集できるソフトはありますが、エクセルは関数が便利なので「CSVを読み込むんでシートに表示」「簡単なフィルター加工等をする」「シートのデータをCSVに出力する」をそれぞれワンクリックで遂行するマクロを作りました。
単一セル内にカンマや改行が含まれていても対処できるようにしています。
Option Explicit
'------------------------------------------------------------------
' CSV読み込み
'------------------------------------------------------------------
Sub CsvReadButton()
Dim i As Long, j As Long, k As Long, str As String
Dim wsSettings As Worksheet
Dim wsRawData As Worksheet
'シート設定
Set wsSettings = ThisWorkbook.Sheets("設定")
Set wsRawData = ThisWorkbook.Sheets("生データ")
'高速化
With Application
.ScreenUpdating = False '処理中はエクセルシートへの変更を画面に反映しない
.Calculation = xlCalculationManual 'セルの関数が処理されるのを防ぐ
End With
'既にあるデータを削除するメッセージ表示
str = MsgBox("「生データ」シートにある情報は上書きされてしまいますが続行しますか？", vbYesNo)
If str = vbNo Then End 'Noを選んだらマクロ終了
'読み取りファイルのダイアログ表示
Dim FilePath As String
FilePath = Application.GetOpenFilename("CSV,*.csv")
If FilePath = "False" Then End 'キャンセルが押されたらマクロ終了
'文字コードを取得
Dim Encoding As String
Encoding = wsSettings.cells(2, 2)
'CSVを読み込んで２次元配列に格納する
Dim csvContent() As String
csvContent = ParseCSV(FilePath, Encoding)
'シートを初期化して貼り付け
wsRawData.cells.Clear
Dim targetRange As Range
Set targetRange = wsRawData.Range("A1").Resize(UBound(csvContent, 1), UBound(csvContent, 2))
targetRange = csvContent
Erase csvContent
'高速化終了
With Application
.ScreenUpdating = True 'エクセルシートへの変更を画面に反映する
.Calculation = xlCalculationAutomatic 'セルの関数が処理されるようにする
End With
'完了メッセージ
wsRawData.Activate
MsgBox "完了しました"
End Sub
'【関数】CSVから読み込んだStringをセルごとに分割して２次元配列に格納する
Function ParseCSV(ByVal FilePath As String, ByVal Encoding As String) As Variant
'CSVファイルの読み込み
Dim Stream As Object
Dim csvString As String
Set Stream = CreateObject("Adodb.Stream")
With Stream
.Type = 1 'バイナリで読み込む(高速化)
.Open 'ストリームを起動
.LoadFromFile FilePath 'csvのパス指定
.Position = 0 'ポジション指定
.Type = 2 'テキストモードに変更
.Charset = Encoding '文字エンコード
csvString = .ReadText 'ファイルを読み込む
.Close 'ストリームの終了
End With
Set Stream = Nothing
'改行をvbLfに統一
csvString = Replace(csvString, vbCrLf, vbLf)
csvString = Replace(csvString, vbCr, vbLf)
Dim i As Long, j As Long, numRows As Long, numCols As Long
Dim inQuote As Boolean: inQuote = False
Dim tempChar As String
'行数と列数を判定する（２連ダブルクオーテーションとセル内の改行/カンマは適切に対処）
numRows = 1
numCols = 1
For i = 1 To Len(csvString)
tempChar = Mid$(csvString, i, 1)
'文字がダブルクオーテーションの場合
If tempChar = """" Then
If inQuote And i < Len(csvString) Then
'次の文字もダブルクオーテーションの場合はスキップ
If Mid$(csvString, i + 1, 1) = """" Then
i = i + 1
Else
inQuote = False 'ダブルクオーテーション内を抜けたフラグ
End If
Else
inQuote = True 'ダブルクオーテーション内に入ったフラグ
End If
End If
'１行目のダブルクオーテーション外のカンマ数で列数を判定する
If tempChar = "," And Not inQuote And numRows = 1 Then
numCols = numCols + 1
End If
'ダブルクオーテーション外の改行コードの数で行数を判定する
If tempChar = vbLf And Not inQuote And i < Len(csvString) Then
numRows = numRows + 1
End If
Next i
ReDim result(1 To numRows, 1 To numCols) As String
Dim currentRow As Long: currentRow = 1
Dim currentCol As Long: currentCol = 1
Dim startFieldPos As Long: startFieldPos = 1
inQuote = False
'２次元配列を埋めていく
For i = 1 To Len(csvString)
tempChar = Mid$(csvString, i, 1)
'文字がダブルクオーテーションの場合
If tempChar = """" Then
If inQuote And i < Len(csvString) Then
'次の文字もダブルクオーテーションの場合はスキップ
If Mid$(csvString, i + 1, 1) = """" Then
i = i + 1
Else
inQuote = False 'ダブルクオーテーション内を抜けたフラグ
End If
Else
inQuote = True 'ダブルクオーテーション内に入ったフラグ
startFieldPos = i + 1
End If
'文字がダブルクオーテーション外のカンマの場合（セルの終わり）
ElseIf tempChar = "," And Not inQuote Then
If Mid$(csvString, i - 1, 1) = """" Then
result(currentRow, currentCol) = Replace(Mid$(csvString, startFieldPos, i - startFieldPos - 1), """""", """")
Else
result(currentRow, currentCol) = Replace(Mid$(csvString, startFieldPos, i - startFieldPos), """""", """")
End If
currentCol = currentCol + 1
startFieldPos = i + 1
'文字がダブルクオーテーション外の改行の場合（行の終わり）
ElseIf tempChar = vbLf And Not inQuote Then
If Mid$(csvString, i - 1, 1) = """" Then
result(currentRow, currentCol) = Replace(Mid$(csvString, startFieldPos, i - startFieldPos - 1), """""", """")
Else
result(currentRow, currentCol) = Replace(Mid$(csvString, startFieldPos, i - startFieldPos), """""", """")
End If
currentRow = currentRow + 1
currentCol = 1
startFieldPos = i + 1
End If
Next i
'最終行が改行で終わらない場合
If startFieldPos <= Len(csvString) Then
result(currentRow, currentCol) = Replace(Mid$(csvString, startFieldPos, Len(csvString) - startFieldPos), """""", """")
End If
ParseCSV = result
End Function
'------------------------------------------------------------------
' データ加工
'------------------------------------------------------------------
Sub EditData()
Dim i As Long, j As Long, k As Long, l As Long, sum As Long
Dim str As String
Dim wsSettings As Worksheet
Dim wsRawData As Worksheet
Dim wsEditData As Worksheet
'シート設定
Set wsSettings = ThisWorkbook.Sheets("設定")
Set wsRawData = ThisWorkbook.Sheets("生データ")
Set wsEditData = ThisWorkbook.Sheets("加工後データ")
'高速化
With Application
.ScreenUpdating = False '処理中はエクセルシートへの変更を画面に反映しない
.Calculation = xlCalculationManual 'セルの関数が処理されるのを防ぐ
End With
'既にあるデータを削除するメッセージ表示
str = MsgBox("「加工後データ」シートにある情報は上書きされてしまいますが続行しますか？", vbYesNo)
If str = vbNo Then End 'Noを選んだらマクロ終了
'フィルター条件取得
Dim arrCondition1() As Variant
Dim arrCondition2() As Variant
arrCondition1 = wsSettings.Range("A10:C18")
arrCondition2 = wsSettings.Range("E10:G18")
'生データ取得
Dim MaxRow As Long, MaxColumn As Long
Dim arrRawData() As Variant
With wsRawData
MaxRow = .cells(.rows.Count, 1).End(xlUp).row
MaxColumn = .cells(4, .columns.Count).End(xlToLeft).Column
arrRawData = .Range(.cells(1, 1), .cells(MaxRow, MaxColumn)).Value
End With
'条件一致判定
Dim Condition1Match() As Integer
Dim Condition2Match() As Integer
Condition1Match = CheckCondition(arrCondition1, arrRawData)
Condition2Match = CheckCondition(arrCondition2, arrRawData)
'どちらかの条件に一致する列を判定
Dim ConditionTotalMatch() As Integer
ReDim ConditionTotalMatch(1 To UBound(arrRawData, 1))
For i = 1 To UBound(arrRawData, 1)
If Condition1Match(i) = 1 Or Condition2Match(i) = 1 Then
ConditionTotalMatch(i) = 1
sum = sum + 1
End If
Next i
'必要列を取得
Dim columnSetting As String
columnSetting = wsSettings.cells(21, 2)
Dim columns As Long, arrColumns() As Variant
arrColumns = wsSettings.Range("B22:B33")
For i = 1 To UBound(arrColumns, 1)
If arrColumns(i, 1) <> "" Then
columns = columns + 1
End If
Next i
'結果配列を作成する
Dim arrResult() As String
j = 1
If columnSetting = "全て" Or columnSetting = "以下を除外" Then
ReDim arrResult(1 To sum + 1, 1 To UBound(arrRawData, 2))
For i = 1 To UBound(arrRawData, 1)
If ConditionTotalMatch(i) = 1 Or i = 1 Then
For k = 1 To UBound(arrRawData, 2)
arrResult(j, k) = arrRawData(i, k)
Next k
j = j + 1
End If
Next i
ElseIf columnSetting = "以下のみ" Then
ReDim arrResult(1 To sum + 1, 1 To columns)
For i = 1 To UBound(arrRawData, 1)
If ConditionTotalMatch(i) = 1 Or i = 1 Then
For k = 1 To UBound(arrRawData, 2)
For l = 1 To UBound(arrColumns, 1)
If arrRawData(1, k) = arrColumns(l, 1) Then arrResult(j, l) = arrRawData(i, k)
Next l
Next k
l = 1
j = j + 1
End If
Next i
End If
Erase arrRawData
'シートを初期化して貼り付け
wsEditData.cells.Clear
Dim targetRange As Range
Set targetRange = wsEditData.Range("A1").Resize(UBound(arrResult, 1), UBound(arrResult, 2))
targetRange = arrResult
'不要列削除
If columnSetting = "以下を除外" Then
For i = UBound(arrResult, 2) To 1 Step -1
For j = 1 To UBound(arrColumns, 1)
If wsEditData.cells(1, i) = arrColumns(j, 1) Then
wsEditData.columns(i).Delete
End If
Next j
Next i
End If
'ヘッダー処理
Dim headerSetting As String
headerSetting = wsSettings.cells(35, 2)
If headerSetting = "削除" Then wsEditData.rows(1).Delete
'高速化終了
With Application
.ScreenUpdating = True 'エクセルシートへの変更を画面に反映する
.Calculation = xlCalculationAutomatic 'セルの関数が処理されるようにする
End With
'完了メッセージ
wsEditData.Activate
MsgBox "完了しました"
End Sub
'【関数】条件に一致する行を判定する
Function CheckCondition(ByRef arrCondition As Variant, ByRef arrRawData As Variant) As Variant
Dim conditionRow As Long, rawDataColumn As Long, rawDataRow As Long, valueIndex As Long, conditions As Long
Dim str As String
Dim ConditionMatch() As Integer
ReDim ConditionMatch(1 To UBound(arrRawData, 1))
'全一致の場合の点数集計
For conditionRow = 1 To UBound(arrCondition, 1)
If arrCondition(conditionRow, 3) = "どれかに一致(含める)" Then
conditions = conditions + 1
ElseIf arrCondition(conditionRow, 3) = "全てに一致しない(除外)" Then
str = arrCondition(conditionRow, 2)
conditions = conditions + 1 + UBound(Split(str, ","))
End If
Next conditionRow
If conditions = 0 Then
CheckCondition = ConditionMatch
Exit Function
End If
'フィルター条件の検証
Dim ConditionValues() As String
For conditionRow = 1 To UBound(arrCondition, 1)
'条件が無くなったら終了
If arrCondition(conditionRow, 3) = "" Then Exit For
'条件値の配列を作成
ConditionValues = Split(arrCondition(conditionRow, 2), ",")
For valueIndex = 0 To UBound(ConditionValues)
If ConditionValues(valueIndex) = "[空欄]" Then ConditionValues(valueIndex) = Empty
Next valueIndex
'条件列の判定
For rawDataColumn = 1 To UBound(arrRawData, 2)
If arrRawData(1, rawDataColumn) = arrCondition(conditionRow, 1) Then Exit For
Next rawDataColumn
'条件に一致していれば条件一致配列に加点
For rawDataRow = 1 To UBound(arrRawData, 1)
If arrCondition(conditionRow, 3) = "どれかに一致(含める)" Then
For valueIndex = 0 To UBound(ConditionValues)
If arrRawData(rawDataRow, rawDataColumn) = ConditionValues(valueIndex) Then ConditionMatch(rawDataRow) = ConditionMatch(rawDataRow) + 1
Next valueIndex
ElseIf arrCondition(conditionRow, 3) = "全てに一致しない(除外)" Then
For valueIndex = 0 To UBound(ConditionValues)
If arrRawData(rawDataRow, rawDataColumn) <> ConditionValues(valueIndex) Then ConditionMatch(rawDataRow) = ConditionMatch(rawDataRow) + 1
Next valueIndex
End If
Next rawDataRow
'条件値の初期化
Erase ConditionValues
Next conditionRow
'全一致は1、それ以外は0にする
For conditionRow = 1 To UBound(ConditionMatch)
If ConditionMatch(conditionRow) = conditions Then
ConditionMatch(conditionRow) = 1
Else
ConditionMatch(conditionRow) = 0
End If
Next conditionRow
CheckCondition = ConditionMatch
End Function
'------------------------------------------------------------------
' CSV出力
'------------------------------------------------------------------
Sub CsvExportButton()
Dim i As Long, j As Long, k As Long, str As String, tmpDate As Date
Dim wsEditData As Worksheet
Dim wsSettings As Worksheet
'シート設定
Set wsSettings = ThisWorkbook.Sheets("設定")
Set wsEditData = ThisWorkbook.Sheets("加工後データ")
'高速化
With Application
.ScreenUpdating = False '処理中はエクセルシートへの変更を画面に反映しない
.Calculation = xlCalculationManual 'セルの関数が処理されるのを防ぐ
End With
'データがなければマクロ終了
If wsEditData.cells(1, 1).Value = "" Then
MsgBox "データがA1セルにありません", vbCritical
End
End If
'ユーザーIDの重複確認
Dim duplicateSetting As Integer
duplicateSetting = wsSettings.cells(41, 2)
If duplicateSetting > 0 Then
If CheckDuplicates(duplicateSetting) = True Then
MsgBox duplicateSetting & "列目に重複データがあります", vbCritical
End
End If
End If
'文字コードを取得
Dim Encoding As String
Encoding = wsSettings.cells(42, 2)
'保存ファイル名のダイアログ表示
Dim FilePath As String
FilePath = Application.GetSaveAsFilename(InitialFileName:="EmployeeImportData.csv", FileFilter:="CSV UTF-8,*.csv")
If FilePath = "False" Then
End 'キャンセルが押されたらマクロ終了
End If
If Dir(FilePath) <> "" Then
If MsgBox("同じ名前のファイルがあります。上書きしますか？", vbYesNo + vbQuestion, "File Exists") = vbNo Then
End
End If
End If
'ストリームの初期設定
Dim Stream As Object
Set Stream = CreateObject("Adodb.Stream")
With Stream
.Charset = Encoding '文字エンコード
.Type = 2 'テキストデータタイプ
.Open 'ストリームを起動
End With
'データを２次元配列に格納
Dim MaxRow As Long, MaxColumn As Long
Dim arrTemp() As Variant
With wsEditData
MaxRow = .cells(.rows.Count, 1).End(xlUp).row
MaxColumn = .cells(4, .columns.Count).End(xlToLeft).Column
arrTemp = .Range(.cells(1, 1), .cells(MaxRow, MaxColumn)).Value
End With
'ダブルクオーテーション設定を取得
Dim DoubleQ As String
DoubleQ = wsSettings.cells(43, 2)
'セル内のダブルクオーテーションは2連にする
If DoubleQ = "あり" Then
For i = LBound(arrTemp, 1) To UBound(arrTemp, 1)
For j = LBound(arrTemp, 2) To UBound(arrTemp, 2)
If InStr(arrTemp(i, j), """") > 0 Then
arrTemp(i, j) = Replace(arrTemp(i, j), """", """""")
End If
arrTemp(i, j) = """" & arrTemp(i, j) & """"
Next j
Next i
Else
For i = LBound(arrTemp, 1) To UBound(arrTemp, 1)
For j = LBound(arrTemp, 2) To UBound(arrTemp, 2)
If InStr(arrTemp(i, j), """") > 0 Then
arrTemp(i, j) = Replace(arrTemp(i, j), """", """""")
arrTemp(i, j) = """" & arrTemp(i, j) & """"
End If
Next j
Next i
End If
'データを書き込む
Dim strLine As String
strLine = ""
For i = LBound(arrTemp, 1) To UBound(arrTemp, 1)
For j = LBound(arrTemp, 2) To UBound(arrTemp, 2)
strLine = strLine & arrTemp(i, j) & ","
Next j
'最後のコンマを除く
strLine = Left(strLine, Len(strLine) - 1)
'行を書き込む
Stream.WriteText strLine & vbLf
strLine = ""
Next i
'ファイルの保存
With Stream
.SaveToFile FilePath, 2 'ファイル存在していても上書き
.Close
End With
'高速化終了
With Application
.ScreenUpdating = True 'エクセルシートへの変更を画面に反映する
.Calculation = xlCalculationAutomatic 'セルの関数が処理されるようにする
End With
MsgBox "完了しました"
End Sub
'【関数】データ重複確認
Function CheckDuplicates(ByVal col As Long) As Boolean
Dim uniqueValues As Collection
Set uniqueValues = New Collection
Dim startRow As Long: startRow = 1
CheckDuplicates = False
'列を配列に格納
Dim arrColumn() As Variant
Dim lastRow As Long
With Worksheets("加工後データ")
lastRow = .cells(.rows.Count, col).End(xlUp).row
If startRow = lastRow Then
Exit Function
End If
arrColumn = .Range(.cells(startRow, col), .cells(lastRow, col)).Value
End With
Dim i As Long
On Error Resume Next
For i = LBound(arrColumn, 1) To UBound(arrColumn, 1)
uniqueValues.Add arrColumn(i, 1), CStr(arrColumn(i, 1))
If Err.Number <> 0 Then
CheckDuplicates = True
Exit For
End If
Next i
On Error GoTo 0
End Function