概要
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プログラム(マクロ)を公開
サンプルファイルのダウンロード
2024/6/30 プログラムを修正しました。
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 = c_ck(buf)
buf = Replace(buf, """", "")
csv_dt = Split(buf, ";") 'CSVデータを分割して配列に格納
Else
csv_dt = Split(buf, ",") 'CSVデータを分割して配列に格納
End If
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) As Long
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データ内のカンマをチェック
Function c_ck(ByVal c_data As String) As String
Dim k As Long
Dim cnt As Long
cnt = 0
For k = 1 To Len(c_data)
If Mid(c_data, k, 1) = """" Then
cnt = cnt + 1
ElseIf Mid(c_data, k, 1) = "," And cnt Mod 2 = 0 Then
Mid(c_data, k, 1) = ";"
End If
Next
c_ck = c_data
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
CSVファイルを取り込む際の注意点
CSVファイルは1つ以上のレコードで構成されており、各レコードは改行によって区切られます。また、レコードは１つ以上の項目で成り立っており、各項目はカンマで区切られます。
そのため、CSVファイルの各データ内に改行やカンマが含まれていると、正常な取り込みを行うことができません。(間違った場所で区切られる)
そこで、当プログラムにおいてはダブルクォーテーションの数で改行のチェックと修正を行い、各項目データ内に含まれるカンマは触らず区切り文字である方のカンマを一旦セミコロンに変換してスプリットしています。(カンマではなくセミコロンで分割する)
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行目以降の処理を高速化
スコープ(変数の適用範囲)を限定する
今回のサンプルではグローバル変数やモジュールレベル変数など広い範囲に適用できる変数は一切使用しておりません。すべてプロシージャレベル変数のみでプログラミングされています。
プロシージャ内で対応できるものは多少面倒でもそうした方がセキュリティ上よいからです。同時に可読性も上がります。また、各変数についても分かりやすくするため極力使いまわしはせず専用のものを使用しています。(その分、多少メモリは消費します)
コメント