トランザクション処理

  データベースに変更を連続して実行する時に、全ての処理が成功した場合だけ、
  データベースへの変更を有効にする処理です。
  
  銀行などの処理で、変更途中にハードの不具合で処理が止まってしまったとします。
  この不具合で預金が紛失してしまうかもしれません。これを防ぐ仕掛けです。
  
  これでトランザクションを開始します。
   DB_Connect.BeginTrans

   エラーがなかったら処理を確定します。
   DB_Connect.CommitTrans

   エラーが発生したらデータを元に戻します。
   DB_Connect.RollbackTrans

Public Const ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="

Sub Insert_Update_With_Transaction()

    Dim DB_Connect                      As ADODB.Connection
    Dim DB_Cmd                          As ADODB.Command
    Dim DB_Record                       As ADODB.Recordset
    
    Dim MDB_Path                        As String
    Dim File_Path1                      As String
    Dim File_Path2                      As String
    Dim Prompt                          As String
    Dim File種類                        As String
    
    Dim Open_Workbook_Name              As String
    Dim i                               As Long
    Dim Max_Row                         As Long
    
    Const DB_Name = "Personnel.mdb"
    
    '各ファイルのパスを設定
    File種類 = "mdb (*.mdb),*mdb"
    Prompt = "「Personnel.mdb」を選択してください。"
    MDB_Path = Application.GetOpenFilename(File種類, , Prompt)

    File種類 = "Excel (*.xls;*.xlsx),*.xls;*.xlsx"
    Prompt = "「社員テーブル」を選択してください。"
    File_Path1 = Application.GetOpenFilename(File種類, , Prompt)

    Prompt = "「部門テーブル」を選択してください。"
    File_Path2 = Application.GetOpenFilename(File種類, , Prompt)
    

    Set DB_Connect = New ADODB.Connection
    
    DB_Connect.Open ConnectionString & MDB_Path & ";"

    Set DB_Cmd = New ADODB.Command

    DB_Cmd.ActiveConnection = DB_Connect
    
    Set DB_Record = New ADODB.Recordset
    DB_Record.ActiveConnection = DB_Connect
    
    'トランザクション開始
    DB_Connect.BeginTrans

    On Error GoTo Catch

    '社員テーブルを開きます
    'Open_Target_File は別のTipsメニュ−で紹介
    Open_Target_File Open_Workbook_Name, File_Path1

    Max_Row = EffectiveRow
    
    For i = 2 To Max_Row
    
        DB_Record.Source = _
        "SELECT 社員番号  FROM 社員テーブル WHERE 社員番号 = " & Range("A" & i)
        
        DB_Record.Open
        
        If DB_Record.EOF Then
            'Range("A" & i) の社員番号が登録されていない
            
            DB_Cmd.CommandText = "INSERT INTO 社員テーブル VALUES(" & _
                  Range("A" & i) & " ,'" & Range("B" & i) & "'," & _
            "'" & Range("C" & i) & "','" & Range("D" & i) & "'," & _
            "'" & Range("E" & i) & "',#" & Range("F" & i) & "#," & _
                  Range("G" & i) & " )"

            DB_Cmd.Execute
        
        Else
            'Range("A" & i) の社員番号が登録されている
            
            DB_Cmd.CommandText = "UPDATE 社員テーブル SET " & _
            "名前        = '" & Range("B" & i) & "'," & _
            "よみ        = '" & Range("C" & i) & "'," & _
            "性別        = '" & Range("D" & i) & "'," & _
            "血液型      = '" & Range("E" & i) & "'," & _
            "生年月日    = #" & Range("F" & i) & "#," & _
            "部署コード  =  " & Range("G" & i) & "  " & _
            "WHERE 社員番号 = " & Range("A" & i)

            DB_Cmd.Execute
            
        End If
            
        DB_Record.Close

    Next
    Workbooks(Open_Workbook_Name).Close
    
    'トランザクション終了 データ処理完了
    DB_Connect.CommitTrans
    
    'トランザクション開始
    DB_Connect.BeginTrans

    On Error GoTo Catch
    
    
    '部門テーブルを開きます
    'Open_Target_File は別のTipsメニュ−で紹介
    Open_Target_File Open_Workbook_Name, File_Path2

    Max_Row = EffectiveRow
    
    For i = 2 To Max_Row
    
        DB_Record.Source = _
        "SELECT 部署コード  FROM 部門テーブル WHERE 部署コード = " & Range("A" & i)
        
        DB_Record.Open
        
        If DB_Record.EOF Then
            'Range("A" & i) の部署コードが登録されていない
            
            DB_Cmd.CommandText = "INSERT INTO 部門テーブル VALUES(" & _
                  Range("A" & i) & " ,'" & Range("B" & i) & "'," & _
            "'" & Range("C" & i) & " ' )"

            DB_Cmd.Execute

        Else
            'Range("A" & i) の部署コードが登録されている
            
            DB_Cmd.CommandText = "UPDATE 部門テーブル SET " & _
            "部門名 = '" & Range("B" & i) & "', " & _
            "課名   = '" & Range("C" & i) & "'  " & _
            "WHERE 部署コード = " & Range("A" & i)

            DB_Cmd.Execute
        
        End If
        
        DB_Record.Close

    Next
    
    'トランザクション終了 データ処理完了
    DB_Connect.CommitTrans

Finally:

    Workbooks(Open_Workbook_Name).Close
    
    If DB_Record.State = 1 Then
        DB_Record.Close
    End If
    
    If Not DB_Record Is Nothing Then
        Set DB_Record = Nothing
    End If
       
    Set DB_Cmd = Nothing
    
    DB_Connect.Close
    
    Set DB_Connect = Nothing
    
    Exit Sub
    
Catch:

    MsgBox "エラー番号  :" & Err.Number & vbCrLf & _
           "エラーの内容:" & Err.Description, vbExclamation
    
    'エラーが発生したのでデータを処理開始前に戻します
    DB_Connect.RollbackTrans
    
    Resume Finally
        
End Sub

  サンプル をダウンロードして、ご使用ください。