VBA Excel宏一直锁定我的Access数据库

我构建了一个宏，用于将Excel工作表中的数据附加到共享Access数据库（Access 2010）

当宏运行时，它会提取单元格值并将其作为一行追加到Access表中。我已经对它进行了多次测试，它在添加数据方面做得非常好

当宏在运行时出现问题。如果我点击数据库，它会立即锁定，不会让我打开数据库。唯一的解决方法是进入VBA并点击重置按钮。出于某种原因，这将解锁数据库

我进入Access数据库，将选项>客户端设置设置为无锁

有没有办法阻止它锁定？为什么close方法不关闭连接并释放数据库

Dim Db As Database
Dim Rs As Recordset
Dim ws As DAO.Workspace

Dim Path As String
Path = "X:\EKTT-Log.accdb"

Set ws = DBEngine.Workspaces(0)

Set Db = ws.OpenDatabase(Path, _
False, False, "MS Access;") ' Learn more http://msdn.microsoft.com/en-us/library/office/ff835343.aspx

Set Rs = Db.OpenRecordset("Results Log", dbOpenTable, dbAppendOnly, dbPessimistic) ' Learn more http://msdn.microsoft.com/en-us/library/office/ff820966(v=office.14).aspx

' Log At a Glance
If Sheets(">>>>").Cells(15, "G") <> "" Then

Rs.AddNew
Rs.Fields("CTYHOCN") = CTYHOCN
Rs.Fields("eCommerce Manager") = eComMgr
Rs.Fields("Timestamp Start") = TimeStart
Rs.Fields("Timestamp Finish") = TimeFinish
Rs.Fields("Global Web Page") = Sheets(">>>>").Cells(15, "B")
Rs.Fields("Keyword Target") = Sheets(">>>>").Cells(15, "G")
Rs.Fields("Est Search Vol") = Sheets(">>>>").Cells(15, "H")
Rs.Fields("Title Tag") = Sheets(">>>>").Cells(15, "C")
Rs.Fields("Meta Description") = Sheets(">>>>").Cells(15, "E")
Rs.Update


Else
'
End If

' Close database & resume screenupdating   
Rs.Close
Db.Close
ws.Close

Set Rs = Nothing
Set Db = Nothing
Set ws = Nothing

Application.ScreenUpdating = True

Dim Db作为数据库
将遥感器作为记录集
Dim ws作为DAO.Workspace
将路径设置为字符串
Path=“X:\EKTT Log.accdb”
设置ws=DBEngine.Workspaces（0）
设置Db=ws.OpenDatabase（路径_
False，False，“MS Access；”了解更多信息http://msdn.microsoft.com/en-us/library/office/ff835343.aspx
Set Rs=Db.OpenRecordset（“结果日志”、dbOpenTable、dbAppendOnly、Db悲观）”了解更多信息http://msdn.microsoft.com/en-us/library/office/ff820966（v=办公室14）aspx
“一目了然
如果表（“>>>”）单元格（15，“G”）”，则
艾德纽卢比
Rs.Fields（“CTYHOCN”）=CTYHOCN
Rs.Fields（“电子商务经理”）=电子商务经理
Rs.Fields（“时间戳开始”）=时间开始
Rs.Fields（“时间戳完成”）=TimeFinish
Rs.Fields（“全局网页”）=表格（“>>>”）。单元格（15，“B”）
Rs.Fields（“关键字目标”）=表格（“>>”）。单元格（15，“G”）
Rs.字段（“Est搜索卷”）=表格（“>>>”）。单元格（15，“H”）
Rs.字段（“标题标签”）=表格（“>>>”）。单元格（15，“C”）
Rs.字段（“元描述”）=表格（“>>>”）.单元格（15，“E”）
Rs.更新
其他的
'
如果结束
'关闭数据库并恢复屏幕更新
Rs.Close
Db.关闭
ws.Close
设置Rs=无
Set Db=Nothing
设置ws=Nothing
Application.ScreenUpdating=True

您可以尝试使用querydfs，而不是像现在这样直接使用记录集。我从未遇到过您在使用它们将数据从Excel写入Access时提到的锁定问题

---

下面是我不久前写的一个答案，详细说明了如何做到这一点：

您可以尝试使用querydfs，而不是像现在这样直接使用记录集。我从未遇到过您在使用它们将数据从Excel写入Access时提到的锁定问题

---

这是我不久前写的一个答案，详细说明了如何做到这一点：

这是我们的解决方案，以防其他人有类似的问题

参考： &

---

这是我们的解决方案，以防其他人有类似的问题

参考： &

Sub DataImport()

' Declare datbase variables
Dim DatabasePath As String
Dim dbs As Database

' Provide database path
DatabasePath = "C:\database.accdb"

' Open database connection
Set dbs = OpenDatabase(DatabasePath)

' Get values
GlobalWebPage = Sheets(">>>>").Cells(15, "B")
KeywordTarget = Sheets(">>>>").Cells(15, "G")
EstSearchVol = Sheets(">>>>").Cells(15, "H")
TitleTag = Sheets(">>>>").Cells(15, "C")
MetaDescription = Sheets(">>>>").Cells(15, "E")

' Escape characters before SQL statement
GlobalWebPage = FixQuote(GlobalWebPage)
KeywordTarget = FixQuote(KeywordTarget)
EstSearchVol = FixQuote(EstSearchVol)
TitleTag = FixQuote(TitleTag)
MetaDescription = FixQuote(MetaDescription)

' Execute SQL statement
dbs.Execute " INSERT INTO ResultsLog " _
        & "(CTYHOCN, eCommerceManager, TimestampStart, TimestampFinish, GlobalWebPage, KeywordTarget, EstSearchVol, TitleTag, MetaDescription) VALUES " _
        & "('" & CTYHOCN & "', '" & eComMgr & "', '" & TimeStart & "', '" & TimeFinish & "', '" & GlobalWebPage & "', '" & KeywordTarget & "', '" & EstSearchVol & "', '" & TitleTag & "', '" & MetaDescription & "');"

' Close the database connection
dbs.Close

End Sub


' Function courtesy of http://mikeperris.com/access/escaping-quotes-Access-VBA-SQL.html
Public Function FixQuote(FQText As String) As String
On Error GoTo Err_FixQuote
FixQuote = Replace(FQText, "'", "''")
FixQuote = Replace(FixQuote, """", """""")
Exit_FixQuote:
Exit Function
Err_FixQuote:
MsgBox Err.Description, , "Error in Function Fix_Quotes.FixQuote"
Resume Exit_FixQuote
Resume 0 '.FOR TROUBLESHOOTING
End Function