コンテンツへスキップ

CSVをエクセルファイルで読み書きする

データ出力を伴う様々なシステムで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を読み込んで2次元配列に格納する
    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をセルごとに分割して2次元配列に格納する
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
    
    '行数と列数を判定する(2連ダブルクオーテーションとセル内の改行/カンマは適切に対処)
    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
        
        '1行目のダブルクオーテーション外のカンマ数で列数を判定する
        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
    
    '2次元配列を埋めていく
    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

    'データを2次元配列に格納
    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