Excel code crashes after a couple of uses, opening a connection to Access

Question

We have an Excel 2016 quoting tool that uses VBA code to compare the product codes entered against an Access database and then update another sheet with the details needed for our CRM system.
This is an interim solution until a more permanent one becomes available.

We can capture 5 quotes, generate the CRM sheet. On the 6th quote when you generate the CRM sheet the following VBA Error shows up.

System Error &H8000FFF (-2147418113)

Fixes I tried, increase the buffer size, clear clipboard. Removing the buffer causes the error almost immediately.

I found in debugging that the crash will happen at cn.Open as it tries to open a connection to Access.

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:\database\CRMSA.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

This looks to be related to memory use because you can get further into the generate process if you have very little open but as soon as you have a lot of items open: Chrome, Outlook and other applications you can get maybe 5 generate attempts.
On a virtual machine with only 4GB of RAM I was able to do this process over 40 times without a single crash.
On my work laptop with 16GB of RAM and only this open I was able to generate about 16 times before that error comes up.

Event log:

The system has called a custom component and that component has failed and generated an exception. This indicates a problem with the custom component. Notify the developer of this component that a failure has occurred and provide them with the information below. Component Prog ID: SC.Pool 455 1 Method Name: IDispenserDriver::CreateResource Process Name: EXCEL.EXE Exception: c0000005 Address: 0X58101018

I removed all custom add-ins and still get this crash. I only have the following MS references in the sheet running namely:

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

I tried rebuilding the database, compact and repair and decompile but it has no effect.
I have white listed the database in AV program with no change.

edit

Module 1 is the first VB script that I think opens the Access database.
Module 2 is VB script that says Cell A in Worksheet A goes to Cell A in Worksheet B, it too is also opening a connection to the Access database but I have not included the formula for the moving part.
There is a third module that compares the data from the Excel sheet with the Access database and then assigns product codes.

Module 1:

Public Function CRM_shortDescr(PROD As String)
Application.ScreenUpdating = False
    Set cn = New ADODB.Connection
    cn.ConnectionString = "DSN=MS Access Database;DBQ=C:\database\CRMSA.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

Module 2 is the one above at the start of this post, missing lines are:

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

Problem appears to be solved and it had nothing to do with the code <_<. KB4484218 is the culprit that is breaking everything somehow.