Accessでクエリの結果をExcelシートに出力する場合、
クエリの結果が配列に格納してあると、シートに貼り付けるのはとても簡単です。
たとえば、Variant型変数vArrayに配列形式で値が格納されているときは、
Range("A5:G500") = vArray
みたいに、配列はExcelと相性が良いのです。上の例はちょっと乱暴ですけどね。
では、Access側でクエリの結果を配列に格納するにはどうするか？
コピーしてそのまま使えるサンプルを紹介します。
なぜ配列に？
配列はExcelと仲良し。Excel出力で効果を発揮します
CollectionやDictionaryなど、配列より柔軟性の高いオブジェクトはありますが、Excelとの親和性に関しては配列が断トツなのです。
セル範囲を配列として扱うことによって、Excel側で個々のセルの評価が行われなくなるので、結果として貼り付けの処理速度が向上するのです。
今回紹介するのはAccessからExcelにデータを出力する場面で使える「Accessクエリの実行結果を配列に格納する」まずはDAOのサンプルです。
【Access VBA】クエリの結果セットを配列に格納して返すサンプル
DAOの参照設定
DAOを使用する場合、参照設定で、
「Microsoft DAO 3.6 Object Library」
または
「Microsoft Office XX.X Access Database Engine Object Library」
のいずれかにチェックを付けてください。
サンプルコード
以下のコードをAccessの標準モジュールに貼り付けてください。
「gbGetData」も「mbSetArray」も１本のモジュールに含めます。
'***************************************************************************
'名称 ：gbGetData
'機能 ：【DAO】クエリ結果セットを配列で返す
'引数 ：vsTableName (I ) String データソース名
' ：rvArray ( O) Variant (返却用)データ配列
' ：vlMax_Col (I ) Long 最終列位置
' ：rsParamName (I ) String パラメータ名
' ：rsParamValue (I ) String パラメータ値
' ：rsMsg ( O) String エラーメッセージ
'戻り値：True = 正常終了, False = 異常終了
'作成 ：2013/05/29 kinacco
'更新 ：
'***************************************************************************
Public Function gbGetData(ByVal vsTableName As String _
, ByRef rvArray As Variant _
, Optional ByVal vlMax_Col As Long _
, Optional ByRef rsParamName As String = "" _
, Optional ByRef rsParamValue As String = "" _
, Optional ByRef rsMsg As String = "") As Boolean
On Error GoTo Err_Sec
Const C_PROC_NAME As String = "gbGetData"
Dim lbRet As Boolean
Dim lbErr As Boolean
Dim lsMsg As String
Dim lobjDBs As DAO.Database
Dim lobjQdf As DAO.QueryDef
Dim lobjRst As DAO.Recordset
lbRet = False
lbErr = False
lsMsg = ""
rsMsg = ""
'--- パラメータチェック ---
If Len(vsTableName) <= 0 Then
lsMsg = "データソース名の受け渡しに失敗しました。"
GoTo EXIT_SEC
End If
'--- DBインスタンスを取得 ---
Set lobjDBs = Application.CurrentDb 'OpenDatabase(lsDataSourcePath)
'--- レポート元データを取得する ---
If Len(rsParamName) > 0 And Len(rsParamValue) > 0 Then
'--- パラメータクエリの場合 ---
Set lobjQdf = lobjDBs.QueryDefs(vsTableName)
lobjQdf.Parameters(rsParamName).Value = rsParamValue
Set lobjRst = lobjQdf.OpenRecordset
Else
Set lobjRst = lobjDBs.OpenRecordset(vsTableName)
End If
'--- 結果セットチェック ---
If lobjRst Is Nothing Then
lsMsg = "[ERR-04]レポートの元データクエリ(" & vsTableName & ")からレコードの取得に失敗しました。"
lbErr = True
GoTo EXIT_SEC
ElseIf lobjRst.EOF Then
lsMsg = "[ERR-05]レポートの元データクエリ(" & vsTableName & ")の件数が0件です"
lbErr = True
GoTo EXIT_SEC
End If
'--- レコードセットの内容を配列に格納 ---
If mbSetArray(lobjRst, rvArray, vlMax_Col, lsMsg) = False Then
If Len(lsMsg) <= 0 Then lsMsg = "[ERR-08]出力用配列へのコピーに失敗しました。(クエリ：" & vsTableName
lbErr = True
GoTo EXIT_SEC
End If
lbRet = Not lbErr
EXIT_SEC:
On Error Resume Next
lobjRst.Close
Set lobjRst = Nothing
If Not lobjDBs Is Nothing Then
lobjDBs.Close
Set lobjDBs = Nothing
End If
rsMsg = lsMsg
gbGetData = lbRet
Exit Function
Err_Sec:
lsMsg = "予期せぬエラーが発生しました。" & vbCrLf & _
"プロシージャ名： " & C_PROC_NAME & vbCrLf & _
"エラー番号：" & Err.Number & vbCrLf & _
"エラー内容：" & Err.Description
Resume EXIT_SEC
End Function
'***************************************************************************
'名称 ：mbSetArray
'機能 ：レコードセットを配列で返す
'引数 ：robjRst (I ) DAO.Recordset
' ：rvArray ( O) Variant (返却用)データ配列
' ：rlColMax (I ) Long 最終列位置
' ：rsMsg ( O) String エラーメッセージ
'戻り値：True = 正常終了, False = 異常終了
'作成 ：2013/05/29 kinacco
'更新 ：
'***************************************************************************
Public Function mbSetArray(ByRef robjRst As DAO.Recordset _
, ByRef rvArray As Variant _
, Optional ByRef rlColMax As Long = 0 _
, Optional ByRef rsMsg As String = "") As Boolean
On Error GoTo Err_Sec
Const C_PROC_NAME As String = "mbSetArray"
Dim lbRet As Boolean
Dim llColMax As Long
Dim i As Long, j As Long
lbRet = False
rsMsg = ""
'--- パラメータチェック ---
If robjRst Is Nothing Then
rsMsg = "元データRecordsetの受け渡しに失敗しました。"
GoTo EXIT_SEC
End If
SysCmd acSysCmdSetStatus, "データを取得しています..."
'--- レコード数を取得する ---
robjRst.MoveLast
'--- フィールド数を取得する ---
If rlColMax > 0 Then
'--- 列数を指定された場合は固定 ---
llColMax = rlColMax
Else
llColMax = robjRst.Fields.Count
End If
'--- 二次元配列を再定義 ---
ReDim rvArray(robjRst.RecordCount - 1, llColMax - 1)
'--- 配列に格納する ---
i = 0
robjRst.MoveFirst
Do Until robjRst.EOF
If i Mod 100 = 0 Then DoEvents
For j = 0 To llColMax
If j > UBound(rvArray, 2) Then Exit For
rvArray(i, j) = robjRst.Fields.Item(j).Value
Next
i = i + 1
robjRst.MoveNext
Loop
lbRet = True
EXIT_SEC:
On Error Resume Next
mbSetArray = lbRet
Exit Function
Err_Sec:
rsMsg = "予期せぬエラーが発生しました。" & vbCrLf & _
"プロシージャ名： " & C_PROC_NAME & vbCrLf & _
"エラー番号：" & Err.Number & vbCrLf & _
"エラー内容：" & Err.Description
Resume EXIT_SEC
End Function
呼び出し例
第1引数にはクエリ名を、第2は返却用で、自分で定義したVariant型の変数をセットして呼び出してください。
第3引数：(省略可能)第1で指定したクエリの列数を指定します。
第4引数：(省略可能)第1のクエリがパラメータクエリの場合、パラメータ名を指定します。
第5引数：(省略可能)第1のクエリのパラメータにセットする値を指定します。
指定できるクエリは選択クエリです。選択クエリならパラメータが含まれていても動きます。
クロス集計クエリは残念ながらそのままでは出力できないので、いったんテーブルに出力して、そのテーブルをデータソースとした選択クエリを作ってください。
尚、アクションクエリは対象外ですのでご容赦ください。
'(Dim objSheet As Excel.Worksheet) ← あらかじめ作成しておいてください。
Dim sMsg As String 'エラーメッセージ用
Dim vArray As Variant 'クエリ結果セット配列
If gbGetData("Q_レポート", vArray, , , , sMsg) = False Then
If Len(sMsg) <= 0 Then
sMsg = "クエリ結果の取得でエラーが発生しました"
End If
GoTo Sub_Err
End If
'--- 貼り付け！ ---
With objSheet
.Range(.Cells(3, 1), .Cells(3 + UBound(vArray, 1), UBound(vArray, 2)))
End With
Exit Sub
Sub_Err:
Msgbox sMsg
Excelの新規Worksheetの作成は、こちらの記事で紹介しています。
ご参考までに。
さいごに
サンプルコードの使用はくれぐれも自己責任でお願いいたしますね。
どこかでお役に立てれば幸いです。
