VBAでDBを操作するならこれを使え！

はじめに

アプリケーションを作成する際、DB操作からは逃げることができません。
私はよくExcel VBA で Access を DB とした業務ツールを作成しています。

DB操作を行うコードを書くことに飽き飽きしてきた今日この頃。

気づいたら、DB操作の汎用コードを作成してしまいました。
せっかくなので、DB操作の汎用コードを公開します(^^)/

☆注意☆

業務ツールで何度も使用しているので、基本的に問題なく動くと思いますが、
ご使用は自己責任でお願いいたします。
不具合などがあった場合も、損害について補償は一切できませんので、あらかじめご了承ください。

DB操作汎用コード

クラスモジュールで実装してます。
今はAccessのみの実装となります。

それではまずインターフェース

IDB

Option Explicit

' **
' * DBの初期設定を行う関数
' *
' * @param {Variant}   args   実装に合わせて自由な引数を渡す
' *
' *
Function Init(ByVal args As Variant)
End Function

' **
' * DBからデータを配列で取得する関数
' *
' * @param {String}   select_sql   データを取得するためのSELECT文
' *
' *
Public Function GetArray(ByVal select_sql As String) As Variant
End Function

' **
' * SQLを実行する関数
' *
' * @param {String}   any_sql   実行したいSQL文
' *
' *
Public Function ExecuteSQL(ByVal any_sql As String) 
End Function

' **
' * DBに配列データをINSERTする関数
' *
' * @param {String}   select_sql   INSERTする対象を取得するSELECT文
' * @param {Variant}   datas   INSERTしたい配列データ（２次元配列）
' *
' *
Public Function InsertByArray(ByVal select_sql As String, ByVal datas As Variant) 
End Function

' **
' * DBに配列データをUPDATEする関数
' *
' * @param {String}   select_sql   UPDATEする対象を取得するSELECT文
' * @param {Variant}   datas   UPDATEしたい配列データ（２次元配列）
' * @param {Variant}   keys   UPDATEしたい配列データの主キーの位置情報（1次元配列）
' *
' *
Public Function UpdateByArray(ByVal select_sql As String, ByVal datas As Variant, ByVal keys As Variant) 
End Function

' **
' * DBに配列データをMERGEする関数
' *
' * @param {String}   select_sql   MERGEする対象を取得するSELECT文
' * @param {Variant}   datas   MERGEしたい配列データ（２次元配列）
' * @param {Variant}   keys   UPDATEしたい配列データの主キーの位置情報（1次元配列）
' *
' *
Public Function MergeByArray(ByVal select_sql As String, ByVal datas As Variant, ByVal keys As Variant) 
End Function

次に実装クラス

※ADODBを使用していますので、ADODBへの参照設定（Microsoft ActiveX Data Objects x.x Library）を行ってください。

DB_Access

Option Explicit

Implements IDB

Private my_db As String
Private RS As Object
Private CN As Object

'Accessの実装なのでAccessファイルパスをセットします。
Function IDB_Init(ByVal args As Variant)
    On Error GoTo ErrorHandler
    my_db = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & args
    Set CN = New ADODB.Connection
    CN.Open my_db
    Exit Function
ErrorHandler:
    Err.Raise 8000, Err.Source, Join(Array("DBが見つかりません。", vbLf, Err.Description), "")
End Function


Public Function IDB_GetArray(ByVal select_sql As String) As Variant
    On Error GoTo ErrorHandler
    Set RS = New ADODB.Recordset
    RS.Open select_sql, CN, adOpenKeyset, adLockReadOnly ' 2023/01/24 読み取り専用に改修
    IDB_GetArray = RSToArray()
    GoTo finally
ErrorHandler:
    Err.Raise 8005, Err.Source, Join(Array("データの取得に失敗しました", vbLf, Err.Description), "")
finally:
    Set RS = Nothing
End Function


Public Function IDB_ExecuteSQL(ByVal any_sql As String) 
    On Error GoTo ErrorHandler
    CN.BeginTrans
    CN.Execute any_sql
    CN.CommitTrans
    
    Exit Function
ErrorHandler:
    CN.RollbackTrans
    Err.Raise 8010, Err.Source, Join(Array("SQLの実行に失敗しました", vbLf, Err.Description), "")
End Function


Public Function IDB_InsertByArray(ByVal select_sql As String, ByVal datas As Variant) 
    Set RS = New ADODB.Recordset
    RS.Open select_sql, CN, adOpenKeyset, adLockOptimistic
    
    On Error GoTo ErrorHandler
    CN.BeginTrans
    Dim i As Long, j As Long
    For i = 1 To UBound(datas, 1)
        RS.AddNew
        For j = 1 To RS.fields.count
            RS(j - 1) = datas(i, j)
        Next j
        RS.Update
    Next i
    CN.CommitTrans
    
    GoTo finally
ErrorHandler:
    CN.RollbackTrans
    Err.Raise 8015, Err.Source, Join(Array("データの挿入に失敗しました", vbLf, Err.Description), "")
finally:
    Set RS = Nothing
End Function


Public Function IDB_UpdateByArray(ByVal select_sql As String, ByVal datas As Variant, ByVal keys As Variant) 
    Set RS = New ADODB.Recordset
    RS.Open select_sql, CN, adOpenKeyset, adLockOptimistic
    
    On Error GoTo ErrorHandler
    CN.BeginTrans
    Call GoUpdate(datas, keys)
    CN.CommitTrans
    
    GoTo finally
ErrorHandler:
    CN.RollbackTrans
    Err.Raise 8020, Err.Source, Join(Array("データの更新に失敗しました", vbLf, Err.Description), "")
finally:
    Set RS = Nothing
End Function


Public Function IDB_MergeByArray(ByVal select_sql As String, ByVal datas As Variant, ByVal keys As Variant) 
    Set RS = New ADODB.Recordset
    RS.Open select_sql, CN, adOpenKeyset, adLockOptimistic
    
    On Error GoTo ErrorHandler
    CN.BeginTrans
    Call GoMerge(datas, keys)
    CN.CommitTrans
    
    GoTo finally
    
ErrorHandler:
    CN.RollbackTrans
    Err.Raise 8025, Err.Source, Join(Array("データの追加更新に失敗しました", vbLf, Err.Description), "")
finally:
    Set RS = Nothing
End Function


'Accessの更新を行う内部ロジック
Private Function GoUpdate(ByVal datas As Variant, ByVal keys As Variant)
    With RS
        Dim i As Long
        Dim j As Long
        Dim filters As Variant
        ReDim filters(UBound(keys))
        
        Dim diff As Long: diff = LBound(datas, 2)
        
        For i = LBound(datas, 1) To UBound(datas, 1)
            'フィルター
            For j = LBound(keys) To UBound(keys)
                filters(j) = Join(Array(RS(keys(j) - diff).name, datas(i, keys(j))), "='") & "'"
            Next j
            .Filter = Join(filters, " AND ")
            
            If .EOF Or .BOF Then    'UPDATE対象なし
                Err.Raise Number:=8021, Description:="更新対象データが見つかりません。ロールバックします。" & vbLf & "場所：配列datas(" & i & ")行目"
            Else    'UPDATE対象あり
                .MoveFirst
                While Not .EOF
                    For j = LBound(datas, 2) To UBound(datas, 2)
                        If Not (IsKey(keys, j)) Then RS(j - diff) = datas(i, j)
                    Next j
                    .Update
                    .MoveNext
                Wend
            End If
        Next i
    End With
End Function


'Accessの追加更新を行う内部ロジック
Private Function GoMerge(ByVal datas As Variant, ByVal keys As Variant)
    With RS
        Dim i As Long, j As Long
        Dim filters As Variant: ReDim filters(UBound(keys))
        Dim colCnt As Long: colCnt = RS.fields.count - 1
        Dim fieldList As Variant: ReDim fieldList(colCnt)
        Dim addList As Variant: ReDim addList(colCnt)
                
        For i = 0 To colCnt
            fieldList(i) = RS(i).name
        Next i
        
        Dim diff As Long: diff = LBound(datas, 2)
        
        For i = LBound(datas, 1) To UBound(datas, 1)
            'フィルター
            For j = LBound(keys) To UBound(keys)
                filters(j) = Join(Array(RS(keys(j) - diff).name, datas(i, keys(j))), "='") & "'"
            Next j
'            .MoveFirst
            .Filter = Join(filters, " AND ")
            
            If .EOF Or .BOF Then
                For j = LBound(datas, 2) To UBound(datas, 2)
                    addList(j - diff) = datas(i, j)
                Next j
                .AddNew fieldList, addList
                GoTo continue
            Else
                .MoveFirst
                While Not .EOF
                    For j = LBound(datas, 2) To UBound(datas, 2)
                        If Not (IsKey(keys, j)) Then RS(j - diff) = datas(i, j)
                    Next j
                    .Update
                    .MoveNext
                Wend
            End If
continue:
        Next i
    End With
End Function

'主キー判定内部ロジック
Private Function IsKey(ByVal keys As Variant, ByVal target As Variant) As Boolean
    Dim key As Variant
    For Each key In keys
        If target = key Then
            IsKey = True
            Exit For
        End If
    Next key
End Function



' レコードセットを配列に変換し、返却する内部ロジック
Private Function RSToArray() As Variant
    On Error GoTo continue
    Dim ary As Variant
    ReDim ary(RS.recordCount - 1, RS.fields.count - 1) '配列の要素数を定義
    Dim rsNum As Long '縦要素（レコードセット）の繰り返し用変数
    Dim fldNum As Long '横要素（フィールド）の繰り返し用変数
    RS.MoveFirst
    Do Until RS.EOF 'レコードセットが終了するまで処理を繰り返す
        For fldNum = 0 To RS.fields.count - 1 'フィールドの数だけ繰り返す
            ary(rsNum, fldNum) = RS(fldNum) '配列に格納
        Next fldNum
        rsNum = rsNum + 1 '縦要素をカウントアップする
        RS.MoveNext '次のレコードに移動する
    Loop
continue:
    RSToArray = ary
End Function

Private Sub Class_Terminate()
    If Not CN Is Nothing Then
        Set CN = Nothing
    End If
End Sub

使用例

Sample

Sub sample()
'    DBインスタンスを作成※IDBとしてインスタンス化
    Dim db As IDB
    Set db = New DB_Access
    
'    Accessファイルパスをセット
    Call db.Init("C:\Users\user\Desktop\sample.accdb")
    
'    データ取得使用例
    Dim datas As Variant
    datas = db.GetArray("SELECT * FROM SampleTBL")

'    SQL文実行例
    Call db.ExecuteSQL("DELETE FROM SampleTBL")
    
'    INSERT例
    datas = Range("A1:D5").Value
    Call db.InsertByArray("SELECT * FROM SampleTBL", datas)
    
'    UPDATE例(単独主キー)
    datas = Range("A1:D5").Value
    Call db.UpdateByArray("SELECT * FROM SampleTBL", datas, Array(1))
    
'    UPDATE例(複合主キー)
    datas = Range("A1:D5").Value
    Call db.UpdateByArray("SELECT * FROM SampleTBL", datas, Array(1, 2, 3))
    
'    MERGE例(単独主キー)
    datas = Range("A1:D5").Value
    Call db.MergeByArray("SELECT * FROM SampleTBL", datas, Array(1))
    
'    MERGE例(複合主キー)
    datas = Range("A1:D5").Value
    Call db.MergeByArray("SELECT * FROM SampleTBL", datas, Array(1, 2, 3))
    
End Sub

終わりに

使用方法についてかなり簡略的に書きましたが、ご質問などありましたら 可能な限り
お答えしますのでお知らせいただければと思います。

また、今後Access以外のDBを実装すつことがあれば同じように公開します。
この記事を読まれているそこのあなたが実装していただいても構いません。
その際はぜひ教えていただければと思います。

この汎用コードが誰かの力になりますように('ω')

以上、ここまでお付き合いいただきありがとうございました。