ExcelVBAでCSVファイルから任意のデータを高速に取り出す

ExcelVBA-マクロ

概要

ExcelVBAでCSVファイルから指定したデータのみを取り出し、さらに加工してExcelファイル形式で高速に出力する方法を紹介します。

特徴

・CSVファイルから任意のデータを取り出し、用意した雛形を使用して自在にファイル出力が可能
・抽出したデータは一旦配列に格納し、あらかじめ設定した内容で加工やデータ変換が可能
・一次元配列、二次元配列、連想配列を効率よく使い分けることで処理の高速化を実現
・CSVデータ内の改行にも完全対応

サンプルで実際にやっていること

WEB上でテストやアンケートを実施し、そのデータをCSV出力してExcelファイルで集計することを想定しています。(e-ラーニングなど)

・取り込みを行うCSVファイルと使用する雛形の関連付けを行う
・指定した複数のファイルを順番に取り込み、それぞれ紐づけした雛形を使用してExcelファイルに一括出力する
・CSVデータの12桁の所属コードから会社コード4桁と所属コード4桁を取り出し、会社一覧、所属一覧シートからコードが一致する会社名、所属名を参照して自動表示する
・CSVファイルのテスト解答データ「Q_001=3&Q_002=9&・・・Q_010=2」を各設問ごとに分割して解答内容を取り出し、設定用シートで選択した解答パターンに変換する
 また、設問数はカウントして自動表示する
・アンケートのセル内改行は、CSVデータを1行取り込んだ際に含まれるダブルクォーテーションの数で判別し、同一行として処理できるよう完全対応済み
・シートの書式や罫線、列幅はすべて自動化
・新規Excelファイルへ出力し、雛形名にて保存する
・配列、連想配列を使い分けることで処理の高速化を実現(その他独自の工夫あり)

完成イメージ

実際に取り込みを行うCSVファイル

テスト解答 (test1.csv)

アンケート結果 (anq1.csv)

設定用シート

取り込みを行うCSVファイルと使用する雛形の関連付けや、テスト解答のパターン選択をします。

雛形シート

テスト解答雛形

アンケート結果雛形

会社一覧・所属一覧シート

会社一覧

所属一覧

CSVファイルの取り込み実行

CSVファイルの取り込みを開始すると、現在の進捗状況が表示されます。

すべての処理が完了すると、出力ファイル名・出力場所が表示されます。

Excelファイルへの出力完了

テスト解答 (テスト解答.xlsx)

アンケート結果 (アンケート結果.xlsx)

自作VBAプログラム(マクロ)を公開

サンプルファイルのダウンロード

VBAコード

ユーザーフォーム

処理の進捗状況をリアルタイムに表示するため、ユーザーフォームを利用しています。

ユーザーフォームのVBAコードはこんな感じです。
すべての処理はメインプログラムで行われるため、とてもシンプルになっています。

メインプログラムのVBAコード

Option Explicit
'ユーザーフォーム表示後にメインルーチンを実行
Sub 処理実行()
    msg1.Show
End Sub

'メインルーチン
Sub 取り込み実行()
    Application.ScreenUpdating = False '処理はバックグラウンドで行う
    Application.DisplayAlerts = False 'ファイル操作の確認メッセージを非表示にする
    '変数宣言
    Dim main As Object
    Set main = Sheets("CSV取込用") '初期設定と取込実行用のメインシート
    Dim file() 'チェックされているCSVファイル名を格納
    Dim temp() 'チェックされている雛形シート名を格納
    Dim i As Long, j As Long, k As Long 'ループ処理用変数
    Dim max As Long '取り込みするCSVファイルの数
    Dim cb As String 'チェックボックス番号
    Dim csv_path As String 'CSVファイルのディレクトリパスを格納
    csv_path = ThisWorkbook.Path '実行用ファイルと同じカレントディレクトリのパス
    Dim buf As String 'CSVデータから1行取得
    Dim csv_dt 'CSVデータ1行を分割して配列に格納
    Dim csv_max As Long 'csv_dtの最大インデックス番号
    Dim menu '雛形の項目の配列
    Dim csv_file As String 'CSVファイルのパスを格納
    Dim csv_cnt As Long 'CSVデータの行カウント
    Dim col_cnt As Long '雛形と一致する項目の列数
    Dim m_index() '雛形と一致するCSVデータのインデックス番号を配列に格納
    Dim dmy_obj As Object '汎用オブジェクト格納用
    Dim dmy_ary '汎用配列格納用
    Dim dmys As String '汎用文字列格納用
    Dim csv_ary() '雛形と一致する項目のCSV抽出データ配列
    Dim szc As Long 'CSVデータ内の所属コードのインデックス番号
    Dim qai As Long '雛形項目の設問数のインデックス番号
    Dim days As Long '雛形項目の実施日時や提出日時のインデックス番号
    Dim qa_ary() 'テスト解答、アンケート結果の配列
    Dim test As Long 'テスト解答、アンケート回答の開始インデックス番号
    Dim q_cnt As Long '設問数
    Dim k_dic '会社一覧辞書の連想配列
    Dim s_dic '所属一覧辞書の連想配列
    Dim k_range '会社一覧、所属一覧の配列データ
    Dim opf As String '出力したファイル一覧
    Dim csv_ck As String 'セル内チェック時の一時退避用
    Dim csv_dq As Long 'CSVデータ内のダブルクォーテーション数
    
    '会社一覧辞書作成
    Set k_dic = CreateObject("Scripting.Dictionary")
    k_range = Sheets("会社一覧").Range("A1").CurrentRegion
    For i = 1 To UBound(k_range)
        k_dic.Add CStr(Format(k_range(i, 1), "0000")), k_range(i, 2)
    Next
    
    '所属一覧辞書作成
    Set s_dic = CreateObject("Scripting.Dictionary")
    k_range = Sheets("所属一覧").Range("A1").CurrentRegion
    For i = 1 To UBound(k_range)
        s_dic.Add CStr(Format(k_range(i, 1), "0000")), k_range(i, 2)
    Next
    
    'チェックされているCSVファイル名と雛形シート名を配列に格納
    max = 0
    dmys = ""
    For i = 1 To 6
        cb = "CheckBox" & CStr(i)
        If main.OLEObjects(cb).Object.Value = True Then
            max = max + 1 'チェックされているファイル数
            ReDim Preserve file(max - 1)
            ReDim Preserve temp(max - 1)
            file(max - 1) = main.Cells(i + 3, 3)
            If Dir(csv_path & "\" & file(max - 1)) = "" Then
                dmys = dmys & vbCrLf & file(max - 1)
            End If
            temp(max - 1) = main.OLEObjects(cb).Object.Caption
        End If
    Next
    
    'ファイルの存在確認
    If max = 0 Then
        MsgBox "ファイルが選択されていません。"
        End
    ElseIf dmys <> "" Then
        MsgBox "以下のファイルが存在しません" & dmys
        MsgBox "プログラムの実行を中止しました"
        End
    End If
    
    'CSVデータから配列に取り込み
    opf = "" '出力ファイル用
    For i = 0 To UBound(file)
        msg1.text1.Text = i + 1 & "/" & UBound(file) + 1 'ユーザーフォームに処理中のファイル数を表示
        DoEvents 'ユーザーフォームの更新
        '雛形の項目を配列に格納
        menu = Sheets(temp(i)).Range("A1").CurrentRegion '雛形の項目を配列に格納(インデックス下限値1に注意)
        col_cnt = UBound(menu, 2) '雛形の項目数
        ReDim m_index(col_cnt - 1)
        
        'CSVデータを1行ずつ配列に格納
        ReDim csv_ary(9999, col_cnt - 1) '最大10000行に設定(行数が多い時はここを変更)
        ReDim qa_ary(9999, 0) '最大10000行に設定(行数が多い時はここを変更)
        szc = 999
        qai = 999
        days = 999
        test = 999
        csv_cnt = 0
        q_cnt = 0
        csv_file = csv_path & "\" & file(i)
        Open csv_file For Input As #1
            Do Until EOF(1)
                Line Input #1, buf 'CSVデータを1行取得
                If InStr(buf, """") > 0 Then 'データ内チェック
                    csv_dq = dqcnt(buf)
                    If csv_dq Mod 2 = 1 Then
                        csv_ck = buf
                        Do
                            Line Input #1, buf 'CSVデータを1行取得
                            csv_ck = csv_ck & vbCrLf & buf
                            csv_dq = dqcnt(csv_ck)
                            If csv_dq Mod 2 = 0 Then
                                buf = csv_ck
                                Exit Do
                            End If
                        Loop
                    End If
                    buf = Replace(buf, """", "")
                End If
                csv_dt = Split(buf, ",") 'CSVデータを分割して配列に格納
                csv_max = UBound(csv_dt) 'CSVデータの最大インデックス番号
                
                If csv_cnt = 0 Then
                    '雛形の項目と一致するCSVデータのインデックス番号を配列に格納
                    For k = 1 To col_cnt
                        For j = 0 To csv_max
                            If menu(1, k) = csv_dt(j) Then
                                m_index(k - 1) = j
                                If menu(1, k) = "所属コード" Then
                                    szc = j '所属コードのインデックス番号
                                ElseIf menu(1, k) = "実施日時" Then
                                    days = k - 1 '実施日時のインデックス番号
                                ElseIf menu(1, k) = "提出日時" Then
                                    days = k - 1 '提出日時のインデックス番号
                                End If
                                Exit For
                            Else
                                m_index(k - 1) = 999
                            End If
                        Next
                        If menu(1, k) = "設問数" Then
                            qai = k - 1 '設問数のインデックス番号
                        End If
                    Next
                    
                    If temp(i) = "テスト解答雛形" Then
                        test = test_index("解答内容1", csv_dt) 'テスト解答の開始インデックス番号を取得
                    ElseIf temp(i) = "アンケート結果雛形" Then
                        test = test_index("回答1", csv_dt) '回答の開始インデックス番号を取得
                        If test < 999 Then
                            q_cnt = csv_max - test '回答数
                            ReDim qa_ary(9999, q_cnt) '最大10000行に設定(行数が多い時はここを変更)
                            For j = 0 To q_cnt
                                qa_ary(0, j) = csv_dt(test + j) '回答の項目を配列に格納
                            Next
                        End If
                    End If
                Else
                    '2行目以降を配列に格納
                    For j = 0 To UBound(m_index)
                        If m_index(j) > csv_max Then
                            csv_ary(csv_cnt - 1, j) = ""
                        Else
                            csv_ary(csv_cnt - 1, j) = csv_dt(m_index(j))
                        End If
                        '会社コードと所属コードの格納
                        If szc = 999 Then
                            
                        ElseIf csv_dt(szc) <> "" Then
                            Select Case menu(1, j + 1)
                                Case "所属コード"
                                    csv_ary(csv_cnt - 1, j) = Right(csv_dt(szc), 4)
                                Case "所属名"
                                    dmys = Right(csv_dt(szc), 4)
                                    If s_dic.Exists(dmys) Then
                                        csv_ary(csv_cnt - 1, j) = s_dic(dmys)
                                    Else
                                        csv_ary(csv_cnt - 1, j) = ""
                                    End If
                                Case "会社コード"
                                    csv_ary(csv_cnt - 1, j) = Left(csv_dt(szc), 4)
                                Case "会社名"
                                    dmys = Left(csv_dt(szc), 4)
                                    If k_dic.Exists(dmys) Then
                                        csv_ary(csv_cnt - 1, j) = k_dic(dmys)
                                    Else
                                        csv_ary(csv_cnt - 1, j) = ""
                                    End If
                            End Select
                        End If
                    Next
                    
                    If temp(i) = "テスト解答雛形" And csv_max >= test Then
                        If InStr(csv_dt(test), "&") > 0 Then
                            dmy_ary = Split(csv_dt(test), "&") 'CSVデータのテスト解答に「&」が含まれていれば分割して配列に格納
                            If UBound(dmy_ary) > q_cnt Then
                                q_cnt = UBound(dmy_ary) '解答数が増えた場合は設問数を更新
                                ReDim Preserve qa_ary(9999, q_cnt) '解答データ用の配列が足りない場合は再設定(10000行を超える場合は「9999」を変更)
                            End If
                            For j = 0 To UBound(dmy_ary)
                                qa_ary(csv_cnt, j) = Replace(dmy_ary(j), "Q_" & Format(j + 1, "000") & "=", "") '「Q_001=」の部分を取り除いて番号のみを配列に格納
                                '選択した解答パターンに応じて変換
                                If qa_ary(csv_cnt, j) <> "" Then
                                    qa_ary(csv_cnt, j) = change_no(qa_ary(csv_cnt, j))
                                End If
                            Next
                        Else
                            qa_ary(csv_cnt, 0) = ""
                        End If
                        
                    ElseIf temp(i) = "アンケート結果雛形" And csv_max >= test Then
                        For j = 0 To q_cnt
                            qa_ary(csv_cnt, j) = csv_dt(test + j) 'アンケート回答はそのまま配列に格納
                        Next
                        
                    End If
                End If
                csv_cnt = csv_cnt + 1
            Loop
        Close #1
        
        'テスト解答の問カテゴリ表示
        If temp(i) = "テスト解答雛形" And q_cnt > 0 Then
            For j = 0 To q_cnt
                qa_ary(0, j) = "問" & j + 1 '「問1」のように設問の項目を作成
            Next
            If qai < 999 And days < 999 Then
                For j = 0 To csv_cnt - 2
                    If csv_ary(j, days) <> "" Then
                        csv_ary(j, qai) = q_cnt + 1 '実施日時がある場合は設問数を表示
                    End If
                Next
            End If
        End If
        
        'シート作成
        Sheets(temp(i)).Copy After:=Sheets(Sheets.Count) '雛形シートをコピー
        Sheets(Sheets.Count).Name = Replace(temp(i), "雛形", "") 'コピーしたシート名から「雛形」を取り除く
        '配列データの書き出しと書式、罫線を設定
        If temp(i) = "テスト解答雛形" Or temp(i) = "アンケート結果雛形" Then
            Call s_out(3, csv_cnt, col_cnt, csv_ary, q_cnt, qa_ary) '項目列が2行かつ自動作成項目を追加した場合
        Else
            Call s_out(2, csv_cnt, col_cnt, csv_ary, 0, 0) '項目列が1行かつ自動作成項目がない場合
        End If
        
        '列幅の自動調整
        If temp(i) <> "アンケート結果雛形" Then
            Sheets(Sheets.Count).Columns.AutoFit
        End If
        
        'ブックに移動
        Sheets(Sheets.Count).Move
        dmys = ActiveSheet.Name
        If Dir(csv_path & "\" & dmys & ".xlsx") <> "" Then
            For j = 1 To 100
                If Dir(csv_path & "\" & dmys & "(" & j & ")" & ".xlsx") = "" Then
                    dmys = dmys & "(" & j & ")"
                    Exit For
                End If
            Next
        End If
        ActiveWorkbook.SaveAs csv_path & "\" & dmys & ".xlsx"
        opf = opf & vbCrLf & dmys & ".xlsx"
        ActiveWorkbook.Close
        main.Select
    Next
    MsgBox max & "個のファイル出力が完了しました。" & vbCrLf & opf & vbCrLf & vbCrLf & "出力場所:" & vbCrLf & csv_path
End Sub

'CSVデータ内のダブルクォーテーション個数
Function dqcnt(ByVal buf As String)
    Dim no As Long
    no = 0
    Dim cnt As Long
    cnt = 0
    Do
        no = InStr(no + 1, buf, """")
        If no = 0 Then
            dqcnt = cnt
            Exit Do
        Else
            cnt = cnt + 1
        End If
    Loop
End Function

'CSVデータから「解答内容1」「回答1」のインデックス番号を取得
Function test_index(ByVal ctg As String, ByVal csv_dt) As Long
    Dim i As Long
    For i = 0 To UBound(csv_dt)
        If csv_dt(i) = ctg Then
            test_index = i
            Exit For
        Else
            test_index = 999
        End If
    Next
End Function

'解答パターンに応じて値を変換
Function change_no(ByVal no As Long) As String
    Dim i As Long
    Dim ob As String
    Dim ob_no As Long
    For i = 1 To 5
        ob = "OptionButton" & CStr(i)
        If Sheets("CSV取込用").OLEObjects(ob).Object.Value = True Then
            ob_no = i
            Exit For
        End If
    Next
    Select Case ob_no
        Case 1
            change_no = CStr(no)
        Case 2
            change_no = Chr(64 + no)
        Case 3
            change_no = Chr(96 + no)
        Case 4
            change_no = Mid("あいうえおかきくけこさしすせそたちつてとなにぬねのはひふへほ", no, 1)
        Case 5
            change_no = Mid("アイウエオカキクケコサシスセソタチツテトナニヌネノハヒフヘホ", no, 1)
    End Select
End Function

'配列データの書き出し、書式設定、罫線など
Function s_out(ByVal put_row As Long, ByVal csv_cnt As Long, ByVal col_cnt As Long, ByVal csv_ary, ByVal q_cnt As Long, ByVal qa_ary)
    With Sheets(Sheets.Count)
        .Cells(put_row, 1).Resize(csv_cnt, col_cnt) = csv_ary '雛形一致項目の配列を書き出し
        If q_cnt > 0 Then
            .Cells(put_row - 1, col_cnt + 1).Resize(csv_cnt, q_cnt + 1) = qa_ary 'テスト解答、アンケート回答の配列を書き出し
            .Range("A1").Copy 'セルをコピー
            .Range(Cells(1, col_cnt + 1), Cells(put_row - 1, col_cnt + 1 + q_cnt)).PasteSpecial (xlPasteFormats) '書式を貼り付け
            Application.CutCopyMode = False 'コピーモードを解除
            .Range(Cells(1, 1), Cells(csv_cnt + put_row - 2, col_cnt + 1 + q_cnt)).Borders.LineStyle = xlDot '内側罫線(ドット)
            .Range(Cells(1, 1), Cells(csv_cnt + put_row - 2, col_cnt + 1 + q_cnt)).BorderAround LineStyle:=xlContinuous '外側罫線(実線)
        Else
            .Range(Cells(1, 1), Cells(csv_cnt + put_row - 2, col_cnt)).Borders.LineStyle = xlDot
            .Range(Cells(1, 1), Cells(csv_cnt + put_row - 2, col_cnt)).BorderAround LineStyle:=xlContinuous
        End If
        .Range("A1").Select 'アクティブセルをA1にセット
    End With
End Function

VBAプログラムについて解説

当サイトではVBA初心者のための解説は一切行っておりません。(他に分かりやすい解説サイトが星の数ほど存在するため)
とは言っても、実は僕自身も初心者です。VBAに関しては実質2~3時間程度しか勉強していません。(ノートにして10ページ程度) 当然、マクロを組んだのも今回が初めてです。
何のノウハウも実績もない状態で一から自分で考えて作った完全自己流のプログラムとなるため、もしかするとあまり参考にならないかもしれません。(かなり個性的で粗削りな内容になっている?)
ただ、VBAプログラミング自体はそれほど難しくなく、基本さえ押さえておけば工夫次第でこれくらいのことは簡単に出来るので、個人的に重要だと思う部分のみを解説していきます。

VBAプログラミングで押さえておくべき基本ルールについて

仕組みを理解する

VBE、モジュール、プロシージャ、オブジェクト、メソッド、プロパティ、各種ステートメントなど、全体がどのように構成されていて、どのようなルールで記述するのかを理解しておく必要があります。

変数について理解する

変数に格納する値の種類によって宣言する方法が変わります。
例:Dim 変数名 As Long (整数)
  Dim 変数名 As String (文字列)
  Dim 変数名 As Object (オブジェクト)
※変数に値を格納する際、通常は「変数名 = 値」でよいが、オブジェクトの場合は「Set 変数名 = オブジェクト」となるため注意が必要

変数の適用範囲(スコープ)について
プロシージャ内で宣言した変数は、宣言したプロシージャ内が適用範囲となり、外側つまりモジュールの先頭で宣言した変数は、同じモジュール内のすべてのプロシージャで変数を共有できます。(その他、各モジュール間で共有できるグローバル変数あり)

配列について理解する

一次元配列、二次元配列、連想配列の特徴や使用方法、また、静的配列と動的配列の違いについて理解する必要があります。
静的配列 → 要素数の変更不可
動的配列 → 要素数の変更可能
また、動的配列でセル範囲から配列を作成した場合は行数に関係なく全て2次元配列となり、要素数の下限が1となる点も注意が必要です。

既に格納された値を保持しながら要素数を変更する「ReDim Preserve 配列名」について
要素数をReDimで宣言しなおすと配列の中身は基本的にすべてリセットされて失われてしまうが、Preserveを使用することで値を保持しながら要素数の上限を変更できます。(下限は変更できない)
※ただし、Preserveを指定した場合は、変更できるのは最下位の次元のみです。
つまり、セル範囲の配列データは(行,列)の二次元配列となるため、変更できるのは二次元目の「列」のみになります。

オブジェクトの種類や階層構造について理解する

Workbook、Worksheet、Range、Cell、コレクションなど、様々なオブジェクトに対してどのように指定するかも重要となります。

プロシージャを理解する

Subプロシージャ、Functionプロシージャ、イベントプロシージャ、引数、戻り値、値渡し、参照渡しなどを理解しておく必要があります。

オマケ:クラスモジュールについて

自作したクラスのメソッドを実行できます。

自分なりに意識して取り組んだこと

処理の高速化

WEB上でテストやアンケートを行った場合、結果出力して集計する際に会社規模によっては膨大なデータ量の処理が必要となり時間がかかります。そのため、以下の点について工夫しました。
・読み込んだCSVデータは一旦配列に格納してからデータ変換を行い、その後配列からセル範囲に一括出力
・会社一覧シートと所属一覧シートの内容は連想配列に格納することでループ処理を使用せずに高速検索が可能
・CSVデータ1行目を取得する際に雛形の項目と一致するCSVデータのインデックス番号を配列に格納することで、2行目以降の処理を高速化

スコープ(変数の適用範囲)を限定する

今回のサンプルではグローバル変数やモジュールレベル変数など広い範囲に適用できる変数は一切使用しておりません。すべてプロシージャレベル変数のみでプログラミングされています。
プロシージャ内で対応できるものは多少面倒でもそうした方がセキュリティ上よいからです。同時に可読性も上がります。また、各変数についても分かりやすくするため極力使いまわしはせず専用のものを使用しています。(その分、多少メモリは消費します)

コメント

タイトルとURLをコピーしました