Excel module not reading Access tables/queries

I have the following VBA code in Excel that calls Access to run a Query to update a table based on dates in two Excel cells.

The code works the first time I run it.  If i try to run it again, I get a read Only error.  If I close the Excel file, and reopen it, the VBA runs.

I checked the task manager to make sure that Access is closed before I run the module again.

Can someone check the code to make sure I have closed all the queries and tables?

Private Sub cmdBtn_Click()
        Dim strDb As String
        Dim appAccess As Access.Application
        Dim ModName As String
        Dim startdt As String
        Dim enddt As String
        Dim MyDb As DAO.Database
        Dim qdef As DAO.QueryDef
        Dim SQL As String
        Dim strWhere As String
       
       
       
        startdt = "#" & Format$(Worksheets("Dashboard").Range("E9").Value, "mm/dd/yyyy") & "#"
        enddt = "#" & Format$(Worksheets("Dashboard").Range("E10").Value, "mm/dd/yyyy") & "#"
       
       
        strDb = "P:\Accounting\NHSN.accdb"
       
        Set appAccess = CreateObject("Access.Application")
       
        With appAccess
       
           
            .OpenCurrentDatabase strDb
           
            .DoCmd.SetWarnings False
           
            Set MyDb = .CurrentDb()
           
            MyDb.QueryDefs.Delete "qry_NHSN_tbl"
       
            strWhere = " WHERE(((dbo_AbstractData.PatientClass) <> 'IN')) AND (dbo_SchAppointmentOrOperations.Description IS NOT NULL) "
            strWhere = strWhere & "GROUP BY dbo_SchOrPatCases.SurgeonName, dbo_AbstractData.Name, dbo_AbstractData.BirthDateTime, dbo_AbstractData.UnitNumber, "
            strWhere = strWhere & "dbo_SchAppointments.DateTime, dbo_SchAppointmentOrOperations.Description, dbo_SchOrPatCases.VisitID, dbo_AbstractData.AccountNumber "
            strWhere = strWhere & "HAVING (dbo_SchAppointments.DateTime)between " & startdt & " and " & enddt & ";"
           
            SQL = "SELECT dbo_SchOrPatCases.SurgeonName AS Surgeon, dbo_AbstractData.Name AS PTName, dbo_AbstractData.BirthDateTime AS DOB, "
            SQL = SQL & "dbo_AbstractData.UnitNumber AS [MedRec#], dbo_SchAppointments.DateTime AS ProcDate, dbo_SchAppointmentOrOperations.Description AS ProcDescr "
            SQL = SQL & " into tblNHSNProcedures "
            SQL = SQL & " FROM (((((dbo_SchOrPatCases LEFT JOIN dbo_AbsOperationProcedures ON dbo_SchOrPatCases.VisitID = dbo_AbsOperationProcedures.VisitID) "
            SQL = SQL & "LEFT JOIN dbo_AbstractData ON dbo_SchOrPatCases.VisitID = dbo_AbstractData.VisitID) LEFT JOIN dbo_AdmVisitOrders "
            SQL = SQL & "ON dbo_SchOrPatCases.VisitID = dbo_AdmVisitOrders.VisitID) LEFT JOIN Sheet1 ON dbo_AbsOperationProcedures.ProcedureCode = Sheet1.ProcedureCode) "
            SQL = SQL & "LEFT JOIN dbo_SchAppointments ON dbo_AbstractData.VisitID = dbo_SchAppointments.VisitID) LEFT JOIN dbo_SchAppointmentOrOperations "
            SQL = SQL & "ON dbo_SchAppointments.AppointmentID = dbo_SchAppointmentOrOperations.AppointmentID "
            SQL = SQL & strWhere
           
           
            Set qdef = MyDb.CreateQueryDef("qry_NHSN_tbl", SQL)
           
            .DoCmd.OpenQuery "qry_NHSN_tbl"
       
            .DoCmd.SetWarnings True
           
            .Quit
        End With
       
        Set appAccess = Nothing
       

End Sub


Thanks

glen
GPSPOWAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

NorieAnalyst Assistant Commented:
Glen

Try closing the query, closing the database and then quitting Access.
qdef.Close

Set qdef = Nothing

MyDb.Close

Set MyDeb = Nothing

.Quit

Open in new window


By the way, why are you rerunning the code?

Are you creating multiple tables?
0
GPSPOWAuthor Commented:
I am not creating multiple tables.

The user may want to do different time period extracts.

So for instance, the first time the open the spreadsheet they set the date parameters to:

startdt = 1/1/2013  (cell E9)
enddt = 2/28/13   (cell E10)

They click a COMMAND button that runs my script and then refresh a linked table to the new Access table created by the script.  Use the table for analysis.

They next want to change the date parameters to:

startdt = 5/1/13 (cell E9)
enddt = 6/30/13 (cell E10)

When you click the COMMAND button to rerun the script I get the following error:

run Time error: 3027

Cannot Update:  database or object is read only

If I can get the Excel Table to run a SQL/Access query instead of running a Table Update Query that would probably work better.  However, I need to be able to pass the Range values as parameters every time the Table is refreshed.

Can this be done?

thanks

glen
0
NorieAnalyst Assistant Commented:
Glen

Of course you can run a query, and it's probably more straightforward than your append query.

I've not worked with DAO much recently but give this a try.
Option Explicit

Private Sub cmdBtn_Click()
Dim MyDb As DAO.Database
Dim rst As DAO.Recordset
Dim ws As Worksheet
Dim SQL As String
Dim strWhere As String
Dim strDb As String
Dim startdt As String
Dim enddt As String
Dim I As Long

    startdt = "#" & Format$(Worksheets("Dashboard").Range("E9").Value, "mm/dd/yyyy") & "#"
    enddt = "#" & Format$(Worksheets("Dashboard").Range("E10").Value, "mm/dd/yyyy") & "#"


    strDb = "P:\Accounting\NHSN.accdb"


    Set MyDb = OpenDatabase(strDb)

    strWhere = " WHERE(((dbo_AbstractData.PatientClass) <> 'IN')) AND (dbo_SchAppointmentOrOperations.Description IS NOT NULL) "
    strWhere = strWhere & "GROUP BY dbo_SchOrPatCases.SurgeonName, dbo_AbstractData.Name, dbo_AbstractData.BirthDateTime, dbo_AbstractData.UnitNumber, "
    strWhere = strWhere & "dbo_SchAppointments.DateTime, dbo_SchAppointmentOrOperations.Description, dbo_SchOrPatCases.VisitID, dbo_AbstractData.AccountNumber "
    strWhere = strWhere & "HAVING (dbo_SchAppointments.DateTime)between " & startdt & " and " & enddt & ";"

    SQL = "SELECT dbo_SchOrPatCases.SurgeonName AS Surgeon, dbo_AbstractData.Name AS PTName, dbo_AbstractData.BirthDateTime AS DOB, "
    SQL = SQL & "dbo_AbstractData.UnitNumber AS [MedRec#], dbo_SchAppointments.DateTime AS ProcDate, dbo_SchAppointmentOrOperations.Description AS ProcDescr "
    SQL = SQL & " FROM (((((dbo_SchOrPatCases LEFT JOIN dbo_AbsOperationProcedures ON dbo_SchOrPatCases.VisitID = dbo_AbsOperationProcedures.VisitID) "
    SQL = SQL & "LEFT JOIN dbo_AbstractData ON dbo_SchOrPatCases.VisitID = dbo_AbstractData.VisitID) LEFT JOIN dbo_AdmVisitOrders "
    SQL = SQL & "ON dbo_SchOrPatCases.VisitID = dbo_AdmVisitOrders.VisitID) LEFT JOIN Sheet1 ON dbo_AbsOperationProcedures.ProcedureCode = Sheet1.ProcedureCode) "
    SQL = SQL & "LEFT JOIN dbo_SchAppointments ON dbo_AbstractData.VisitID = dbo_SchAppointments.VisitID) LEFT JOIN dbo_SchAppointmentOrOperations "
    SQL = SQL & "ON dbo_SchAppointments.AppointmentID = dbo_SchAppointmentOrOperations.AppointmentID "
    SQL = SQL & strWhere

    Set rst = MyDb.OpenRecordset(SQL, dbReadOnly)

    Set ws = Worksheets.Add    ' create new worksheet for results of query

    For I = 0 To rst.Fields.Count - 1
        ws.Cells(1, I + 1).Value = rst.Fields(0).Name
    Next I

    ws.Range("A1").CopyFromRecordset rst
    
    rst.Close
    
    Set rst = Nothing
    
    MyDb.Close
    
    Set MyDb = nothin
    
End Sub

Open in new window

0
Newly released Acronis True Image 2019

In announcing the release of the 15th Anniversary Edition of Acronis True Image 2019, the company revealed that its artificial intelligence-based anti-ransomware technology – stopped more than 200,000 ransomware attacks on 150,000 customers last year.

GPSPOWAuthor Commented:
I am getting the error:

Run Time Error: 3343

Unrecognized Database Format:

Set MyDb = OpenDatabase(strDb)  is highlighted by the debugger.




I double checked the path and it is correct.

Glen
0
NorieAnalyst Assistant Commented:
Like I said I don't normally use DAO.

Why not try it with ADO?

Option Explicit

Sub cmdBtn_Click()
Dim con As ADODB.Connection
Dim rst As ADODB.Recordset
Dim dbPath As String
Dim ws As Worksheet
Dim I As Long
Dim strSQL As String
Dim strWhere As String
Dim startdt As String
Dim enddt As String

    startdt = "#" & Format$(Worksheets("Dashboard").Range("E9").Value, "mm/dd/yyyy") & "#"
    enddt = "#" & Format$(Worksheets("Dashboard").Range("E10").Value, "mm/dd/yyyy") & "#"

    dbPath = "P:\Accounting\NHSN.accdb"

    strWhere = strWhere & " WHERE(((dbo_AbstractData.PatientClass) <> 'IN')) AND (dbo_SchAppointmentOrOperations.Description IS NOT NULL) "
    strWhere = strWhere & "GROUP BY dbo_SchOrPatCases.SurgeonName, dbo_AbstractData.Name, dbo_AbstractData.BirthDateTime, dbo_AbstractData.UnitNumber, "
    strWhere = strWhere & "dbo_SchAppointments.DateTime, dbo_SchAppointmentOrOperations.Description, dbo_SchOrPatCases.VisitID, dbo_AbstractData.AccountNumber "
    strWhere = strWhere & "HAVING (dbo_SchAppointments.DateTime)between " & startdt & " and " & enddt & ";"

    strSQL = strSQL & "SELECT dbo_SchOrPatCases.SurgeonName AS Surgeon, dbo_AbstractData.Name AS PTName, dbo_AbstractData.BirthDateTime AS DOB, "
    strSQL = strSQL & "dbo_AbstractData.UnitNumber AS [MedRec#], dbo_SchAppointments.DateTime AS ProcDate, dbo_SchAppointmentOrOperations.Description AS ProcDescr "
    strSQL = strSQL & " FROM (((((dbo_SchOrPatCases LEFT JOIN dbo_AbsOperationProcedures ON dbo_SchOrPatCases.VisitID = dbo_AbsOperationProcedures.VisitID) "
    strSQL = strSQL & "LEFT JOIN dbo_AbstractData ON dbo_SchOrPatCases.VisitID = dbo_AbstractData.VisitID) LEFT JOIN dbo_AdmVisitOrders "
    strSQL = strSQL & "ON dbo_SchOrPatCases.VisitID = dbo_AdmVisitOrders.VisitID) LEFT JOIN Sheet1 ON dbo_AbsOperationProcedures.ProcedureCode = Sheet1.ProcedureCode) "
    strSQL = strSQL & "LEFT JOIN dbo_SchAppointments ON dbo_AbstractData.VisitID = dbo_SchAppointments.VisitID) LEFT JOIN dbo_SchAppointmentOrOperations "
    strSQL = strSQL & "ON dbo_SchAppointments.AppointmentID = dbo_SchAppointmentOrOperations.AppointmentID "
    strSQL = strSQL & strWhere


    Set con = New ADODB.Connection
    con.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
    con.Open

    Set rst = New ADODB.Recordset
    rst.Open strSQL

    Set ws = Worksheets.Add    ' create new worksheet for results of query

    For I = 0 To rst.Fields.Count - 1
        ws.Cells(1, I + 1).Value = rst.Fields(0).Name
    Next I

    ws.Range("A1").CopyFromRecordset rst

    rst.Close

    Set rst = Nothing

    con.Close

    Set con = Nothing

End Sub

Open in new window

0
GPSPOWAuthor Commented:
Dim con as ADODB.Connection object is not defined.

Any other suggestions?

Thanks

Glen
0
NorieAnalyst Assistant Commented:
Glen

My fault - you need a reference to Microsoft ActiveX Data Objects x.x Library.

By the way, have you considered doing this with a MS Query and a query that takes parameter values from cells on a worksheet.
0
GPSPOWAuthor Commented:
That is one of my other options.

How do I do set up the MS Query?

I am still getting the ADODB object not defined.

Thanks

Glen
0
NorieAnalyst Assistant Commented:
Glen

Did you add the reference I mentioned above?

Does it work if you replace this,
Dim con As ADODB.Connection
Dim rst As ADODB.Recordset

Open in new window

with this.
Dim con As Object
Dim rst As Object

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
GPSPOWAuthor Commented:
Yes it worked thanks
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Applications

From novice to tech pro — start learning today.