Excel 代码在几次使用后崩溃，打开与 Access 的连接

Question

>我们有一个 Excel 2016 报价工具，该工具使用 VBA 代码将输入的产品代码与 Access 数据库进行比较，然后使用我们的 CRM 系统所需的详细信息更新另一个工作表.
这是一个临时解决方案，直到有更永久的解决方案可用。

我们可以捕获 5 个报价，生成 CRM 表。在生成CRM表的第6个报价中，将显示以下VBA错误。

系统错误 &H8000FFF (-2147418113(

我尝试过的修复，增加缓冲区大小，清除剪贴板。删除缓冲区几乎立即导致错误。

我在调试中发现崩溃将在尝试打开与 Access 的连接时cn.Open发生。

Function CRM_Update(PROD As String)
Application.ScreenUpdating = False
If PROD = "" Then
emptyline = emptyline + 1
Exit Function
Else
emptyline = 0
End If
Set cn = New ADODB.Connection
cn.ConnectionString = "DSN=MS Access Database;DBQ=C:databaseCRMSA.accdb;DriverId=25;FIL=MS Access;MaxBufferSize=4096;PageTimeout=5;"
cn.Open
Set rs = New ADODB.Recordset**
rs.Open "select * from ARTGROUP WHERE  ART = '" & PROD & "';", cn, adOpenStatic
If rs.RecordCount = 0 Then
MsgBox (PROD & "  " & " not found in article group")
Exit Function
End If

这看起来与内存使用有关，因为如果您打开的项目很少，您可以进一步进入生成过程，但一旦打开了很多项目：Chrome、Outlook 和其他应用程序，您可能会获得 5 次生成尝试.
在只有 4GB RAM 的虚拟机上，我能够执行此过程 40 多次而不会发生一次崩溃。/<>在我的工作笔记本电脑上使用16GB的RAM，只有这个打开，我才能在该错误出现之前生成大约16次。

事件日志：

系统调用了自定义组件，但该组件失败 并生成了异常。这表示自定义存在问题 元件。通知此组件的开发人员故障 发生并向他们提供以下信息。组件程序 编号：SC。池 455 1 方法名称：IDispenser驱动程序：：创建资源 进程名称： EXCEL.EXE 异常： c0000005 地址： 0X58101018

我删除了所有自定义加载项，但仍然出现此崩溃。我在运行的工作表中只有以下 MS 参考，即：

VB for Applications
MS Excel 16.0 Object Library
OLE Automation
MS Office 16.0 Object Library>MS Access 16.0 Object Library
Microsoft ActiveX Data Objects 2.8 Library

我尝试重建数据库，压缩并修复和反编译，但它没有效果.
我在AV程序中将数据库列入白名单，没有更改。

编辑

模块 1 是我认为打开 Access 数据库的第一个 VB 脚本。

模块2 是 VB 脚本，它说工作表 A 中的单元格 A 转到工作表 B 中的单元格 A，它也打开了与 Access 数据库的连接，但我没有包含移动部分的公式。
还有第三个模块，用于将 Excel 工作表中的数据与 Access 数据库进行比较，并且然后分配产品代码。

模块 1：

Public Function CRM_shortDescr(PROD As String)
Application.ScreenUpdating = False
Set cn = New ADODB.Connection
cn.ConnectionString = "DSN=MS Access Database;DBQ=C:databaseCRMSA.accdb;DriverId=25;FIL=MS Access;MaxBufferSize=4096;PageTimeout=5;"
'   The database name was set incorrectly here. Changed to correct name.
cn.Open
Set rs = New ADODB.Recordset
rs.Open "select * from ARTGROUP WHERE  ART = '" & PROD & "';", cn, adOpenStatic
If rs.RecordCount = 0 Then
MsgBox (PROD & "  " & " not found in article group")
Exit Function
End If
PRGR = rs!crm
rs.Close
rs.Open "select * from PRGR WHERE  PRGR = '" & Left(PRGR, 2) & "';", cn, adOpenStatic
If rs.RecordCount = 0 Then
MsgBox (PRGR & "  " & " not found in article group")
Exit Function
End If
CRM_shortDescr = rs!Descr
rs.Close
End Function

模块 2 是本文开头的模块 2，缺少的行是：

italyrow = 19 + emptyline
linenumber = ActiveCell.Row
linenumbercrm = linenumber - italyrow
<Formual starts to move from Sheet A to Sheet B but looks like the following
`Worksheets("CRM").Cells(linenumbercrm, 1).Value = Worksheets("Local Quotation").Range("COUNTRY")>
rs.Close
End Function

Answer 1

问题似乎已解决，与代码 <_<无关。KB4484218是以某种方式破坏一切的罪魁祸首。>