Excel VBA ActiveX Data Objects を使ってAccessデータベースを操作するための簡単なクラスモジュール

ExcelからAccessデータベースのテーブルを編集したり、データをワークシートに持ってきたりするとき、ActiveX Data Objects(ADOX)を使うと便利です。

ただ、宣言や初期設定が面倒なので、クラスモジュールにまとめてしまうとコードがスッキリします。

以下のクラスは、ひとつのデータベースから複数のテーブルを取得し、参照・更新することを想定しています。複数のデータベースを一気に扱う場合は、ADODB.ConnectionをDictionary等でまとめると便利かと思います。用途に応じて改造してご利用ください。

必要な参照設定：Microsoft ActiveX Data Objects *.* Library

クラスモジュール

Private DBC As ADODB.Connection

Public Function OpenDatabase(database_path) As Boolean
    On Error GoTo openError
    Set DBC = New ADODB.Connection
    With DBC
        .Provider = "Microsoft.Ace.OLEDB.12.0"
        .Properties("Data Source").Value = database_path
        .Open
    End With
    OpenDatabase = True
    Exit Function
   
openError:
    OpenDatabase = False
End Function

Public Function OpenRecordset(com_SQL) As ADODB.Recordset
    On Error GoTo openError
    Dim open_recordset As New ADODB.Recordset
    With open_recordset
        .ActiveConnection = DBC
        .Source = com_SQL
        .CursorType = adOpenKeyset
        .LockType = adLockOptimistic
        .CursorLocation = adUseClient
        .Open
    End With
   
    Set OpenRecordset = open_recordset
    Exit Function
   
openError:
    Set OpenRecordset = Nothing
   
End Function

使用例（標準モジュール）

データベースのテーブルを読み込み、ワークシートに全てを転記します。Recordsetをワークシートに読み込む「Range.CopyFromRecordset」という便利なメソッドがあるのですが、項目名を１行目に読み込むという単純かつ重要な動作を行えません。そこで、Recordset.Fields.Itemからひとつづつワークシートに読み込む必要があります。

Public Sub getRecordsetFromDb()
   
    Const myDbPath = "C:\myDb\test01.accdb"

    Dim myAdo As New ado_tool
    If myAdo.OpenDatabase(myDbPath) = False Then
        MsgBox "Can't open database:" & myDbPath
        Exit Sub
    End If

    Application.ScreenUpdating = False

    Dim testRecordset As ADODB.Recordset
    Set testRecordset = myAdo.OpenRecordset("SELECT * FROM TESTTABLE")

    With Thisworkbook.Worksheet("testResult")
        .Cells.Clear

        'get field items to row 1
        Dim cnt_clm
        For cnt_clm = 1 To testRecordset.Fields.Count
              .Cells(1, cnt_clm) = testRecordset.Fields.Item(cnt_clm - 1).Name
        Next

        'get records to row 2~
        .Range("A2").CopyFromRecordset testRecordset

    End With

    Application.ScreenUpdating = True
    MsgBox "finished"
 
End Sub