如何修复Excel VBA操作Access时出现的运行时错误3251

错误触发原因 #

该报错核心是你打开的ADODB记录集不支持写入操作，常见诱因有5种：

• Access目标表Public_Deposits未设置主键，ADODB默认无法识别唯一行，锁定写入权限
• 引用的ADODB组件版本过低，或者游标/锁类型和数据库Provider不兼容
• Access数据库文件被设置了只读属性，或者被其他用户以独占方式打开
• 记录集打开后游标状态异常，未获取到写入权限
• 代码未及时释放数据库连接，残留锁导致后续操作无写入权限

分步修复方案 #

第一步：先做基础配置检查 #

1. 打开你的Database.accdb，找到Public_Deposits表进入设计视图，确认ID字段已设置为主键（字段旁有钥匙图标），如果没设置就右键ID字段选择「主键」保存即可
2. 检查数据库文件属性：右键Database.accdb→属性，取消勾选「只读」选项
3. 检查VBA引用：打开VBA编辑器→工具→引用，找到Microsoft ActiveX Data Objects 6.1 Library（或2.8版本，优先选高版本）勾选确认，取消勾选旧版本的ADODB库

第二步：优化代码逻辑 #

你可以选择继续用记录集方式，或者改用更稳定的直接执行SQL语句方式，两种修改方案如下：

方案1：修改原有记录集逻辑（适配现有代码）

Private Sub CommandButton1_Click()

    ''''''''Add Validation here '''''''''''''
    If IsDate(Me.txtdate1.Value) = False Then
        MsgBox "Please enter the correct Transaction_Date", vbCritical
        Exit Sub
    End If
    
    If Me.txtcampany1.Value = "" Then
        MsgBox "Please enter the Campany", vbCritical
        Exit Sub
    End If
     
    If Me.txttrans1.Value = "" Then
        MsgBox "Please enter the Type_Transaction", vbCritical
        Exit Sub
    End If
    
    If Me.txtdebit.Value <> "" Then
        If IsNumeric(Me.txtdebit.Value) = False Then
            MsgBox "Please enter the correct Debit", vbCritical
            Exit Sub
        End If
    End If
    
    If Me.txtcredit.Value <> "" Then
        If IsNumeric(Me.txtcredit.Value) = False Then
            MsgBox "Please enter the correct credit", vbCritical
            Exit Sub
        End If
    End If
    
    If Me.txtbank1.Value = "" Then
        MsgBox "Please enter the By_Bank", vbCritical
        Exit Sub
    End If
    
    If Me.txtStuff1.Value = "" Then
        MsgBox "Please enter the Stuff", vbCritical
        Exit Sub
    End If
    
    If Me.Texremr1.Value = "" Then
        MsgBox "Please enter the Comment", vbCritical
        Exit Sub
    End If
    
    If Me.Textdenu.Value = "" Then
        MsgBox "Please enter the Deposits_Number", vbCritical
        Exit Sub
    End If
    
     If Me.Textattech.Value = "" Then
        MsgBox "Please enter the Attchment_File", vbCritical
        Exit Sub
    End If
    
    If Me.bra1.Value = "" Then
        MsgBox "Please enter the Branch", vbCritical
        Exit Sub
    End If
    
    If Me.depf.Value = "" Then
        MsgBox "Please enter the Deposits_For", vbCritical
        Exit Sub
    End If
    
    '''''''''''''''''''''''''''''''''''''''''
    Dim cnn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim qry As String
           
    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\Database.accdb"
    
    If Me.txtId.Value <> "" Then
        qry = "SELECT * FROM Public_Deposits WHERE ID = " & Me.txtId.Value
    Else
        qry = "SELECT * FROM Public_Deposits Where ID = 0"
    End If
    
    ' 修改游标和锁参数，增加写入权限校验
    rst.Open qry, cnn, adOpenDynamic, adLockOptimistic
    ' 提前判断是否支持更新，避免运行时报错
    If Not rst.Supports(adAddNew) Or Not rst.Supports(adUpdate) Then
        MsgBox "当前数据库无写入权限，请检查数据库配置", vbCritical
        rst.Close: Set rst = Nothing
        cnn.Close: Set cnn = Nothing
        Exit Sub
    End If
    
    If rst.RecordCount = 0 Then
        rst.AddNew
    End If
    
    rst.Fields("Transaction_Date").Value = VBA.CDate(Me.txtdate1.Value)
    rst.Fields("Campany").Value = Me.txtcampany1.Value
    rst.Fields("Type_Transaction").Value = Me.txttrans1.Value
    
    If Me.txtdebit.Value <> "" Then rst.Fields("Debit").Value = Me.txtdebit.Value
    If Me.txtcredit <> "" Then rst.Fields("credit").Value = Me.txtcredit
    rst.Fields("By_Bank").Value = Me.txtbank1.Value
    rst.Fields("Stuff").Value = Me.txtStuff1.Value
    
    rst.Fields("Comment").Value = Me.Texremr1.Value
    rst.Fields("Deposits_Number").Value = Me.Textdenu.Value
    rst.Fields("Attchment_File").Value = Me.Textattech.Value ' 补充原有代码遗漏的字段赋值
    rst.Fields("Branch").Value = Me.bra1.Value
    rst.Fields("Deposits_For").Value = Me.depf.Value
    rst.Fields("UpdateTimestamp").Value = VBA.Now
    rst.Update
  
    ' 新增资源释放逻辑，避免连接残留
    rst.Close: Set rst = Nothing
    cnn.Close: Set cnn = Nothing
    
    Me.txtdate1.Value = ""
    Me.txtcampany1.Value = ""
    Me.txttrans1.Value = ""
    Me.txtdebit.Value = ""
    Me.txtcredit.Value = ""
    Me.txtbank1.Value = ""
    Me.txtStuff1.Value = ""
    Me.Texremr1.Value = ""
    Me.Textdenu.Value = ""
    Me.Textattech.Value = ""
    Me.bra1.Value = ""
    Me.depf.Value = ""
           
    MsgBox "Updated Successfully", vbInformation
    
    Call Me.List_box_Data
End Sub

方案2：改用直接执行SQL方式（更稳定，无记录集锁问题）

这种方式不需要打开记录集，直接执行INSERT/UPDATE语句，几乎不会触发3251错误，把原有记录集操作部分替换为以下代码即可：

Dim cnn As New ADODB.Connection
Dim qry As String
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\Database.accdb"

If Me.txtId.Value <> "" Then
    ' 已有ID执行更新
    qry = "UPDATE Public_Deposits SET " & _
        "Transaction_Date=#" & Format(CDate(Me.txtdate1.Value), "yyyy-mm-dd") & "#," & _
        "Campany='" & Replace(Me.txtcampany1.Value, "'", "''") & "'," & _
        "Type_Transaction='" & Replace(Me.txttrans1.Value, "'", "''") & "'," & _
        "Debit=" & IIf(Me.txtdebit.Value = "", "Null", Me.txtdebit.Value) & "," & _
        "credit=" & IIf(Me.txtcredit.Value = "", "Null", Me.txtcredit.Value) & "," & _
        "By_Bank='" & Replace(Me.txtbank1.Value, "'", "''") & "'," & _
        "Stuff='" & Replace(Me.txtStuff1.Value, "'", "''") & "'," & _
        "Comment='" & Replace(Me.Texremr1.Value, "'", "''") & "'," & _
        "Deposits_Number='" & Replace(Me.Textdenu.Value, "'", "''") & "'," & _
        "Attchment_File='" & Replace(Me.Textattech.Value, "'", "''") & "'," & _
        "Branch='" & Replace(Me.bra1.Value, "'", "''") & "'," & _
        "Deposits_For='" & Replace(Me.depf.Value, "'", "''") & "'," & _
        "UpdateTimestamp=#" & Now() & "# " & _
        "WHERE ID=" & Me.txtId.Value
Else
    ' 无ID执行新增
    qry = "INSERT INTO Public_Deposits(Transaction_Date,Campany,Type_Transaction,Debit,credit,By_Bank,Stuff,Comment,Deposits_Number,Attchment_File,Branch,Deposits_For,UpdateTimestamp) VALUES(" & _
        "#" & Format(CDate(Me.txtdate1.Value), "yyyy-mm-dd") & "#," & _
        "'" & Replace(Me.txtcampany1.Value, "'", "''") & "'," & _
        "'" & Replace(Me.txttrans1.Value, "'", "''") & "'," & _
        IIf(Me.txtdebit.Value = "", "Null", Me.txtdebit.Value) & "," & _
        IIf(Me.txtcredit.Value = "", "Null", Me.txtcredit.Value) & "," & _
        "'" & Replace(Me.txtbank1.Value, "'", "''") & "'," & _
        "'" & Replace(Me.txtStuff1.Value, "'", "''") & "'," & _
        "'" & Replace(Me.Texremr1.Value, "'", "''") & "'," & _
        "'" & Replace(Me.Textdenu.Value, "'", "''") & "'," & _
        "'" & Replace(Me.Textattech.Value, "'", "''") & "'," & _
        "'" & Replace(Me.bra1.Value, "'", "''") & "'," & _
        "'" & Replace(Me.depf.Value, "'", "''") & "'," & _
        "#" & Now() & "#)"
End If

cnn.Execute qry
cnn.Close: Set cnn = Nothing

内容的提问来源于stack exchange，提问作者mohamed anwer