本記事では、このパフォーマンス課題を解決するため、Microsoftが提供するデータアクセス技術であるADO(ActiveX Data Objects)およびDAO(Data Access Objects)をVBAで活用し、データベース接続とデータ処理を劇的に高速化する手法を解説します。特に、以下の要件を満たすことを目指します。
graph TD
subgraph Excelアプリケーション
A["Excelシート (入力データ/出力先)"]
end
subgraph VBAモジュール
B("VBAコード - 初期設定")
B -- GUI更新停止 --> C{"ADO/DAOオブジェクト初期化"}
C -- DB接続確立 --> D["高速化処理"]
D -- データ読み込み (配列バッファ) --> E{"ADO/DAOレコードセット操作"}
E -- トランザクション処理 --> F["データベースへ一括書き込み"]
F -- OR --> G["データベースから一括読み込み"]
G -- データ書き込み (配列バッファ) --> H("VBAコード - 終了処理")
H -- GUI更新再開 --> I["Excelシート (結果反映)"]
end
subgraph Accessデータベース
J["Accessテーブル"]
end
A --> B
D --> J
J --> D
I <-- H
3. 実装:再現可能な高速化コード
3.1. 共通準備 (Win32 API宣言と参照設定)
以下のコードはExcelとAccess共通で使用します。
Win32 API GetTickCount の宣言: 処理時間の計測に使用します。
VBAエディタ (Alt+F11) を開き、「挿入」>「標準モジュール」で新しいモジュールを作成し、以下のコードを記述します。
'// 処理時間計測用Win32 API
#If VBA7 Then ' 64bit/32bit Office対応
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
#Else
Private Declare Function GetTickCount Lib "kernel32" () As Long
#End If
参照設定:
VBAエディタで「ツール」>「参照設定」を開きます。
ADO用: Microsoft ActiveX Data Objects X.X Library (最新版を選択、例: 6.1) にチェックを入れます。
DAO用: Microsoft DAO X.X Object Library (最新版を選択、例: 3.6または12.0) にチェックを入れます。
'// ExcelからAccessへ大量データ高速書き込み (ADO)
Sub Generate_TestData_Excel(ByVal numRows As Long)
Dim ws As Worksheet
Dim i As Long
Dim startTime As Long
Set ws = ThisWorkbook.Sheets("データ")
' 初期化
ws.Cells.ClearContents
ws.Range("A1:D1").Value = Array("氏名", "メールアドレス", "登録日")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
startTime = GetTickCount()
' 配列にデータを作成
Dim data(1 To numRows, 1 To 3) As Variant
For i = 1 To numRows
data(i, 1) = "ユーザー_" & Format(i, "00000")
data(i, 2) = "user" & i & "@example.com"
data(i, 3) = DateSerial(2023, 1, 1) + Int(Rnd * 365) ' ランダムな日付
Next i
' シートに一括書き込み
ws.Range("A2").Resize(numRows, 3).Value = data
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox numRows & "件のテストデータをExcelに生成しました。" & vbCrLf & _
"所要時間: " & (GetTickCount() - startTime) / 1000 & "秒", vbInformation
End Sub
Const ACCESS_DB_PATH As String = "C:\Temp\SampleDB.accdb" ' ★DBファイルのパスを修正してください
Sub Test_Insert_Users_ADO_Optimized()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim ws As Worksheet
Dim arrData As Variant
Dim lRow As Long
Dim startTime As Long
Dim numRows As Long
Dim currentCalcMode As XlCalculation
' データを生成 (10,000行)
numRows = 10000
Call Generate_TestData_Excel(numRows)
Set ws = ThisWorkbook.Sheets("データ")
' 高速化設定
Application.ScreenUpdating = False
Application.EnableEvents = False
currentCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo ErrorHandler
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
startTime = GetTickCount()
' 接続文字列 (Access 2007以降の場合)
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ACCESS_DB_PATH & ";"
' Excelデータを配列に一括読み込み (ヘッダ行を除く)
arrData = ws.Range("A2").Resize(numRows, 3).Value
' トランザクション開始
cn.BeginTrans
' レコードセットを開く (バッチ更新モード)
rs.Open "tblUsers", cn, adOpenKeyset, adLockBatchOptimistic, adCmdTable
For lRow = 1 To UBound(arrData, 1) ' 配列は1ベース
rs.AddNew
rs!氏名 = arrData(lRow, 1)
rs!メールアドレス = arrData(lRow, 2)
rs!登録日 = arrData(lRow, 3)
Next lRow
' バッチ更新
rs.UpdateBatch
' トランザクションコミット
cn.CommitTrans
MsgBox numRows & "件のユーザーデータをAccess (ADO, 高速) に挿入しました。" & vbCrLf & _
"所要時間: " & (GetTickCount() - startTime) / 1000 & "秒", vbInformation
ExitProcedure:
' オブジェクトの解放とリソースのクリーンアップ
If Not rs Is Nothing Then
If rs.State = adStateOpen Then rs.Close
Set rs = Nothing
End If
If Not cn Is Nothing Then
If cn.State = adStateOpen Then cn.Close
Set cn = Nothing
End If
' 元の設定に戻す
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = currentCalcMode
Exit Sub
ErrorHandler:
If Not cn Is Nothing Then
If cn.State = adStateOpen Then
cn.RollbackTrans ' エラー時はロールバック
MsgBox "エラー発生。トランザクションをロールバックしました。" & vbCrLf & _
"エラー: " & Err.Description, vbCritical
End If
End If
Resume ExitProcedure
End Sub
Sub Test_Insert_Users_ADO_Slow()
Dim cn As ADODB.Connection
Dim ws As Worksheet
Dim lRow As Long
Dim startTime As Long
Dim numRows As Long
Dim currentCalcMode As XlCalculation
' データを生成 (10,000行)
numRows = 10000
Call Generate_TestData_Excel(numRows)
Set ws = ThisWorkbook.Sheets("データ")
' 高速化設定 (比較のため、ここでは最低限に)
Application.ScreenUpdating = False
Application.EnableEvents = False
currentCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo ErrorHandler
Set cn = New ADODB.Connection
startTime = GetTickCount()
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ACCESS_DB_PATH & ";"
' 1行ずつSQLをINSERT (遅いパターン)
Dim sSQL As String
For lRow = 2 To numRows + 1 ' Excelシートは2行目から
sSQL = "INSERT INTO tblUsers (氏名, メールアドレス, 登録日) VALUES ('" & _
Replace(ws.Cells(lRow, 1).Value, "'", "''") & "', '" & _
Replace(ws.Cells(lRow, 2).Value, "'", "''") & "', #" & _
Format(ws.Cells(lRow, 3).Value, "yyyy/mm/dd") & "#);"
cn.Execute sSQL, , adCmdText ' SQL実行
Next lRow
MsgBox numRows & "件のユーザーデータをAccess (ADO, 遅い - 1行ずつINSERT) に挿入しました。" & vbCrLf & _
"所要時間: " & (GetTickCount() - startTime) / 1000 & "秒", vbInformation
ExitProcedure:
If Not cn Is Nothing Then
If cn.State = adStateOpen Then cn.Close
Set cn = Nothing
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = currentCalcMode
Exit Sub
ErrorHandler:
MsgBox "エラー発生。" & vbCrLf & "エラー: " & Err.Description, vbCritical
Resume ExitProcedure
End Sub
'// AccessからExcelへ大量データ高速読み込み (DAO)
Const ACCESS_DB_PATH_DAO As String = "C:\Temp\SampleDB.accdb" ' ★DBファイルのパスを修正してください
Sub Test_Read_Users_DAO_Optimized()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim ws As Worksheet
Dim arrRawData As Variant ' DAO.Recordset.GetRows の生データ
Dim arrFormattedData As Variant ' Excel書き込み用に整形したデータ
Dim lRow As Long, lCol As Long
Dim startTime As Long
Dim currentCalcMode As XlCalculation
Set ws = ThisWorkbook.Sheets("結果")
' 高速化設定
Application.ScreenUpdating = False
Application.EnableEvents = False
currentCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo ErrorHandler
startTime = GetTickCount()
' データベースを開く
Set db = OpenDatabase(ACCESS_DB_PATH_DAO)
' レコードセットを開く
Set rs = db.OpenRecordset("SELECT ID, 氏名, メールアドレス, 登録日 FROM tblUsers ORDER BY ID", dbOpenSnapshot)
' Excelシートのヘッダ
ws.Cells.ClearContents
ws.Range("A1:D1").Value = Array("ID", "氏名", "メールアドレス", "登録日")
If Not rs.EOF Then
' GetRowsで全データを配列に一括読み込み
arrRawData = rs.GetRows ' arrRawData(列インデックス, 行インデックス) の形式で取得される
' GetRowsの配列は0ベース、Excelは1ベース、かつ配列の次元が逆
' Excel書き込み用に (行, 列) 形式の配列に整形
ReDim arrFormattedData(1 To UBound(arrRawData, 2) + 1, 1 To UBound(arrRawData, 1) + 1)
For lRow = 0 To UBound(arrRawData, 2)
For lCol = 0 To UBound(arrRawData, 1)
arrFormattedData(lRow + 1, lCol + 1) = arrRawData(lCol, lRow)
Next lCol
Next lRow
' Excelシートに一括書き込み
ws.Range("A2").Resize(UBound(arrFormattedData, 1), UBound(arrFormattedData, 2)).Value = arrFormattedData
End If
MsgBox rs.RecordCount & "件のユーザーデータをAccess (DAO, 高速) からExcelに読み込みました。" & vbCrLf & _
"所要時間: " & (GetTickCount() - startTime) / 1000 & "秒", vbInformation
ExitProcedure:
' オブジェクトの解放とリソースのクリーンアップ
If Not rs Is Nothing Then
If rs.State = adStateOpen Then rs.Close
Set rs = Nothing
End If
If Not db Is Nothing Then
If db.State = dbStateOpen Then db.Close
Set db = Nothing
End If
' 元の設定に戻す
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = currentCalcMode
Exit Sub
ErrorHandler:
MsgBox "エラー発生。" & vbCrLf & "エラー: " & Err.Description, vbCritical
Resume ExitProcedure
End Sub
Sub Test_Read_Users_DAO_Slow()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim ws As Worksheet
Dim lRow As Long
Dim startTime As Long
Dim currentCalcMode As XlCalculation
Set ws = ThisWorkbook.Sheets("結果")
' 高速化設定 (比較のため、ここでは最低限に)
Application.ScreenUpdating = False
Application.EnableEvents = False
currentCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo ErrorHandler
startTime = GetTickCount()
Set db = OpenDatabase(ACCESS_DB_PATH_DAO)
Set rs = db.OpenRecordset("SELECT ID, 氏名, メールアドレス, 登録日 FROM tblUsers ORDER BY ID", dbOpenSnapshot)
' Excelシートのヘッダ
ws.Cells.ClearContents
ws.Range("A1:D1").Value = Array("ID", "氏名", "メールアドレス", "登録日")
lRow = 2 ' データ書き込み開始行
' 1セルずつデータを読み書き (遅いパターン)
If Not rs.EOF Then
Do While Not rs.EOF
ws.Cells(lRow, 1).Value = rs!ID
ws.Cells(lRow, 2).Value = rs!氏名
ws.Cells(lRow, 3).Value = rs!メールアドレス
ws.Cells(lRow, 4).Value = rs!登録日
lRow = lRow + 1
rs.MoveNext
Loop
End If
MsgBox rs.RecordCount & "件のユーザーデータをAccess (DAO, 遅い - 1セルずつ) からExcelに読み込みました。" & vbCrLf & _
"所要時間: " & (GetTickCount() - startTime) / 1000 & "秒", vbInformation
ExitProcedure:
If Not rs Is Nothing Then
If rs.State = adStateOpen Then rs.Close
Set rs = Nothing
End If
If Not db Is Nothing Then
If db.State = dbStateOpen Then db.Close
Set db = Nothing
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = currentCalcMode
Exit Sub
ErrorHandler:
MsgBox "エラー発生。" & vbCrLf & "エラー: " & Err.Description, vbCritical
Resume ExitProcedure
End Sub
コメント