Excel VBA のクラスを使ってデータベースへ接続する（ADO）

2017/10/02 2018/07/16

データベースの処理をクラスモジュールに書く

ExcelVBAで、クラス使用する方法の詳細については、VBAで、クラスを作成（クラスモジュール・インスタンス）を参照してください。
また、ADOで、データベースに接続する方法に関しては、Excel VBA データベース（ADO）を参照してください。

データベースへの接続をクラスを使用して処理する例です。
ここでは、データベースへの接続・解除、トランザクションの処理等をクラスモジュールに記述します。クラス名は「DBConnection」とします（サンプルVBAソースその１）。
実際にクラスを利用するには、標準モジュールを使用します。
・「Access に接続し、重複レコードを削除」（サンプルVBAソースその２）
・「Excel にデータベースとして接続しデータを表示」（サンプルVBAソースその３）

サンプルVBAソースその１（クラスモジュール）

　
Option Explicit

'-------------------------------------------------------------------------------------
'接続処理
'-------------------------------------------------------------------------------------
'Access に接続
Const ACCESSDB = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
                 "C:\Users\excelwork.info\excel\" & _
                 "mydb1.accdb"

'Excel に接続
Const EXCELDB = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
                 "C:\Users\excelwork.info\excel\" & _
                "excel_データベース.xlsx" & _
                ";Extended Properties=""Excel 12.0;HDR=Yes;"""


Private cn As ADODB.Connection
Private rs As ADODB.Recordset

'-------------------------------------------------------------------------------------
' コンストラクタ
'-------------------------------------------------------------------------------------
Private Sub class_initialize()

    If Not rs Is Nothing Then rs.Close

End Sub

'-------------------------------------------------------------------------------------
' デストラクタ
'-------------------------------------------------------------------------------------
Private Sub class_terminate()
    
    On Error Resume Next
    If Not rs Is Nothing Then rs.Close
    Set rs = Nothing
    
    cn.Close
    Set cn = Nothing
    
End Sub

'-------------------------------------------------------------------------------------
' データベース接続
'【引数】DBType    接続するDBを指定
'                  accessdb … Accessデータベースへ接続
'                  excelldb … Excelをデータベースとして接続
'【戻値】接続成功：True ／ 接続失敗：False（Boolean）
'-------------------------------------------------------------------------------------
Public Function DBConnect(ByVal DBType As String) As Boolean

    Dim ConnectingString As String
    
    Select Case DBType
    
        Case "accessdb"
            ConnectingString = ACCESSDB
        
        Case "exceldb"
            ConnectingString = EXCELDB
        
        Case Else
            GoTo ErrHandler
    
    End Select
    
    On Error GoTo ErrHandler
    
    Set cn = New ADODB.Connection
    cn.ConnectionString = ConnectingString
    cn.ConnectionTimeout = 2
    cn.Open
    DBConnect = True
    
    Exit Function
    
ErrHandler:
    DBConnect = False
    
    
End Function

'-------------------------------------------------------------------------------------
' SQL文を実行する（Select 文）
'【引数】strSQL    SQL文
'【戻値】Recordset オブジェクト
'-------------------------------------------------------------------------------------
Public Function Run(strSQL As String) As ADODB.Recordset

    Set rs = New ADODB.Recordset
    
    'SQL文実行（読み取り専用、共有ロック）
    rs.Open strSQL, cn, adOpenKeyset, adLockOptimistic, adCmdText
    
    Set Run = rs

End Function

'-------------------------------------------------------------------------------------
' SQL文を実行する（Insert into文、Delete 文など）
'【引数】strSQL    SQL文（String）
'【戻値】変更されたレコード数（Long）
'-------------------------------------------------------------------------------------
Public Function Exec(strSQL As String) As Long

    Dim ARecNum As Long
    
    cn.Execute strSQL, ARecNum
    
    Exec = ARecNum

End Function

'-------------------------------------------------------------------------------------
'トランザクション開始
'-------------------------------------------------------------------------------------
Public Sub BeginTr()
    cn.BeginTrans
End Sub

'-------------------------------------------------------------------------------------
' トランザクションコミット
'-------------------------------------------------------------------------------------
Public Sub CommitTr()
    cn.CommitTrans
End Sub

'-------------------------------------------------------------------------------------
' トランザクションロールバック
'-------------------------------------------------------------------------------------
Public Sub RollbackTr()
    cn.RollbackTrans
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

Option Explicit

'-------------------------------------------------------------------------------------

'接続処理

'-------------------------------------------------------------------------------------

'Access に接続

Const ACCESSDB = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _

"C:\Users\excelwork.info\excel\" & _

"mydb1.accdb"

'Excel に接続

Const EXCELDB = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _

"C:\Users\excelwork.info\excel\" & _

"excel_データベース.xlsx" & _

";Extended Properties=""Excel 12.0;HDR=Yes;"""

Private cn As ADODB.Connection

Private rs As ADODB.Recordset

'-------------------------------------------------------------------------------------

' コンストラクタ

'-------------------------------------------------------------------------------------

Private Sub class_initialize()

If Not rs Is Nothing Then rs.Close

End Sub

'-------------------------------------------------------------------------------------

' デストラクタ

'-------------------------------------------------------------------------------------

Private Sub class_terminate()

On Error Resume Next

If Not rs Is Nothing Then rs.Close

Set rs = Nothing

cn.Close

Set cn = Nothing

End Sub

'-------------------------------------------------------------------------------------

' データベース接続

'【引数】DBType 接続するDBを指定

' accessdb … Accessデータベースへ接続

' excelldb … Excelをデータベースとして接続

'【戻値】接続成功：True ／接続失敗：False（Boolean）

'-------------------------------------------------------------------------------------

Public Function DBConnect(ByVal DBType As String) As Boolean

Dim ConnectingString As String

Select Case DBType

Case "accessdb"

ConnectingString = ACCESSDB

Case "exceldb"

ConnectingString = EXCELDB

Case Else

GoTo ErrHandler

End Select

On Error GoTo ErrHandler

Set cn = New ADODB.Connection

cn.ConnectionString = ConnectingString

cn.ConnectionTimeout = 2

cn.Open

DBConnect = True

Exit Function

ErrHandler:

DBConnect = False

End Function

'-------------------------------------------------------------------------------------

' SQL文を実行する（Select 文）

'【引数】strSQL SQL文

'【戻値】Recordset オブジェクト

'-------------------------------------------------------------------------------------

Public Function Run(strSQL As String) As ADODB.Recordset

Set rs = New ADODB.Recordset

'SQL文実行（読み取り専用、共有ロック）

rs.Open strSQL, cn, adOpenKeyset, adLockOptimistic, adCmdText

Set Run = rs

End Function

'-------------------------------------------------------------------------------------

' SQL文を実行する（Insert into文、Delete 文など）

'【引数】strSQL SQL文（String）

'【戻値】変更されたレコード数（Long）

'-------------------------------------------------------------------------------------

Public Function Exec(strSQL As String) As Long

Dim ARecNum As Long

cn.Execute strSQL, ARecNum

Exec = ARecNum

End Function

'-------------------------------------------------------------------------------------

'トランザクション開始

'-------------------------------------------------------------------------------------

Public Sub BeginTr()

cn.BeginTrans

End Sub

'-------------------------------------------------------------------------------------

' トランザクションコミット

'-------------------------------------------------------------------------------------

Public Sub CommitTr()

cn.CommitTrans

End Sub

'-------------------------------------------------------------------------------------

' トランザクションロールバック

'-------------------------------------------------------------------------------------

Public Sub RollbackTr()

cn.RollbackTrans

End Sub

サンプルVBAソースその２（標準モジュール）

　
'-------------------------------------------------------------------------------
' 【クラス・データベース】
' Access ファイル（mydb1.accdb）に接続し、
' 社員フィールドの重複レコードを削除
'-------------------------------------------------------------------------------
Sub Sample_DataBaseClass_Access()

    '参照設定:Microsoft ActiveX Data Objects 6.1 Library

    Dim DBFileName As String
    Dim DBClass As DBConnection
    Dim rs As ADODB.Recordset
    Dim strSQL As String
    Dim i As Long
    Dim j As Long
    Dim del_num()
    Dim tmp As String
    
    On Error GoTo ErrHandler_End
    
    Set DBClass = New DBConnection
    DBClass.DBConnect ("accessdb")
    
    strSQL = "select 社員, ID from テーブル6 " & _
             "where 社員 in " & _
             "( select 社員 from テーブル6 as tmp group by 社員 " & _
             "having count(*)>1) " & _
             "order by 社員,ID"
    
    Set rs = DBClass.Run(strSQL)
    
    i = 0
    tmp = ""
    Do Until rs.EOF
        If tmp = rs(0).Value Then
            ReDim Preserve del_num(i)
            del_num(i) = CLng(rs(1).Value)
            i = i + 1
        Else
            tmp = rs(0).Value
        End If
        rs.MoveNext
    Loop
    
    On Error GoTo 0
    On Error GoTo ErrHandler
    
    'トランザクション開始
    DBClass.BeginTr
    
    strSQL = "delete from テーブル6 where ID in (" & Join(del_num, ",") & ")"
    DBClass.Exec (strSQL)
    
    'トランザクション終了（変更の保存）
    DBClass.CommitTr
    
    On Error GoTo 0
    
ErrHandler:
    If Err.Number <> 0 Then
        'トランザクション終了（変更の破棄）
        DBClass.RollbackTr
        MsgBox "データは変更されませんでした"
    End If
    
    Set rs = Nothing
    Set DBClass = Nothing
    
    Exit Sub

ErrHandler_End:
    MsgBox "データベースエラー"

End Sub

'-------------------------------------------------------------------------------

' 【クラス・データベース】

' Access ファイル（mydb1.accdb）に接続し、

' 社員フィールドの重複レコードを削除

'-------------------------------------------------------------------------------

Sub Sample_DataBaseClass_Access()

'参照設定:Microsoft ActiveX Data Objects 6.1 Library

Dim DBFileName As String

Dim DBClass As DBConnection

Dim rs As ADODB.Recordset

Dim strSQL As String

Dim i As Long

Dim j As Long

Dim del_num()

Dim tmp As String

On Error GoTo ErrHandler_End

Set DBClass = New DBConnection

DBClass.DBConnect ("accessdb")

strSQL = "select 社員, ID from テーブル6 " & _

"where 社員 in " & _

"( select 社員 from テーブル6 as tmp group by 社員 " & _

"having count(*)>1) " & _

"order by 社員,ID"

Set rs = DBClass.Run(strSQL)

i = 0

tmp = ""

Do Until rs.EOF

If tmp = rs(0).Value Then

ReDim Preserve del_num(i)

del_num(i) = CLng(rs(1).Value)

i = i + 1

Else

tmp = rs(0).Value

End If

rs.MoveNext

Loop

On Error GoTo 0

On Error GoTo ErrHandler

'トランザクション開始

DBClass.BeginTr

strSQL = "delete from テーブル6 where ID in (" & Join(del_num, ",") & ")"

DBClass.Exec (strSQL)

'トランザクション終了（変更の保存）

DBClass.CommitTr

On Error GoTo 0

ErrHandler:

If Err.Number <> 0 Then

'トランザクション終了（変更の破棄）

DBClass.RollbackTr

MsgBox "データは変更されませんでした"

End If

Set rs = Nothing

Set DBClass = Nothing

Exit Sub

ErrHandler_End:

MsgBox "データベースエラー"

End Sub

実行結果

サンプルVBAソースその２実行前の Access（mydb1.accdb）テーブル6

サンプルVBAソースその２実行後の Access（mydb1.accdb）テーブル6

サンプルVBAソースその３（標準モジュール）

　
'-------------------------------------------------------------------------------
' 【クラス・データベース】
' Excel ファイル（excel_データベース.xlsx）にデータベースとして接続し、
' 商品一覧表を表示する
'-------------------------------------------------------------------------------
Sub Sample_DataBaseClass_Excel()

    '参照設定:Microsoft ActiveX Data Objects 6.1 Library

    Dim DBFileName As String
    Dim DBClass As DBConnection
    Dim rs As ADODB.Recordset
    Dim strSQL As String
    Dim i As Long
    Dim j As Long
    
    On Error GoTo ErrHandler
    
    Set DBClass = New DBConnection
    DBClass.DBConnect ("exceldb")
    
    strSQL = "select * from [Sheet1$]"
    Set rs = DBClass.Run(strSQL)
    
    With Worksheets("Sheet1")
        .Cells.Clear
        i = 1
        .Cells.Clear
        Do Until rs.EOF
            For j = 0 To rs.Fields.Count - 1
                If i = 1 Then .Cells(i, j + 1) = rs(j).Name
                .Cells(i + 1, j + 1) = rs(j).Value
            Next j
            rs.MoveNext
            i = i + 1
        Loop
        .Columns("A:H").AutoFit
    End With
    
    Set rs = Nothing
    Set DBClass = Nothing
    
    Exit Sub
    
ErrHandler:
    MsgBox "データベースエラー"

End Sub