きなこSHOW

VBAと日々の戯言

Accessクエリの結果を配列で返すサンプルVBA

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」も1本のモジュールに含めます。

'***************************************************************************
'名称 :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の作成は、こちらの記事で紹介しています。
ご参考までに。

kinaccco.hatenadiary.com

 

さいごに

サンプルコードの使用はくれぐれも自己責任でお願いいたしますね。
どこかでお役に立てれば幸いです。