在 Excel 2016 中运行 VBA 时出现 OLE 错误？

Question

I'm trying to use Excel as a Database, and I'm following a tutorial from this site .

Problem is, whenever I try to "Update Drop Downs" in the file below, I get this error: "Microsoft is waiting for another application to complete an OEL action".

What am I missing or doing wrong here, and how do I get this right?

I'm using Excel 2016 Home & Student that's uptodate. I also enable Macros when opening the Workbook.

The same file runs perfect when open in Excel 2007. I've also noticed that Microsoft ActiveX Data Objects 6.0 Library references a "msado60.dll" in the example, whereas, it's a "msado60.tlb" file in Excel 2016 (which I use).

Link to Excel File

Private Sub cmdShowData_Click()
    'populate data
    strSQL = "SELECT * FROM [data$] WHERE "
    If cmbProducts.Text <> "" Then
        strSQL = strSQL & " [Product]='" & cmbProducts.Text & "'"
    End If

    If cmbRegion.Text <> "" Then
        If cmbProducts.Text <> "" Then
            strSQL = strSQL & " AND [Region]='" & cmbRegion.Text & "'"
        Else
            strSQL = strSQL & " [Region]='" & cmbRegion.Text & "'"
        End If
    End If

    If cmbCustomerType.Text <> "" Then
        If cmbProducts.Text <> "" Or cmbRegion.Text <> "" Then
            strSQL = strSQL & " AND [Customer Type]='" & cmbCustomerType.Text & "'"
        Else
            strSQL = strSQL & " [Customer Type]='" & cmbCustomerType.Text & "'"
        End If
    End If

    If cmbProducts.Text <> "" Or cmbRegion.Text <> "" Or cmbCustomerType.Text <> "" Then
        'now extract data
        closeRS

        OpenDB

        rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
        If rs.RecordCount > 0 Then
            Sheets("View").Visible = True
            Sheets("View").Select
            Range("dataSet").Select
            Range(Selection, Selection.End(xlDown)).ClearContents

            'Now putting the data on the sheet
            ActiveCell.CopyFromRecordset rs
        Else
            MsgBox "I was not able to find any matching records.", vbExclamation + vbOKOnly
            Exit Sub
        End If

        'Now getting the totals using Query
        If cmbProducts.Text <> "" And cmbRegion.Text <> "" And cmbCustomerType.Text <> "" Then
            strSQL = "SELECT Count([data$].[Call ID]) AS [CountOfCall ID], [data$].[Resolved] " & _
            " FROM [Data$] WHERE ((([Data$].[Product]) = '" & cmbProducts.Text & "' ) And " & _
            " (([Data$].[Region]) =  '" & cmbRegion.Text & "' ) And (([Data$].[Customer Type]) =  '" & cmbCustomerType.Text & "' )) " & _
            " GROUP BY [data$].[Resolved];"

            closeRS
            OpenDB

            rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
            If rs.RecordCount > 0 Then
                Range("L6").CopyFromRecordset rs
            Else
                Range("L6:M7").Clear
                MsgBox "There was some issue getting the totals.", vbExclamation + vbOKOnly
                Exit Sub
            End If
        End If
    End If
End Sub

Private Sub cmdUpdateDropDowns_Click()
    strSQL = "Select Distinct [Product] From [data$] Order by [Product]"
    closeRS
    OpenDB
    cmbProducts.Clear

    rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
    If rs.RecordCount > 0 Then
        Do While Not rs.EOF
            cmbProducts.AddItem rs.Fields(0)
            rs.MoveNext
        Loop
    Else
        MsgBox "I was not able to find any unique Products.", vbCritical + vbOKOnly
        Exit Sub
    End If

    '----------------------------
    strSQL = "Select Distinct [Region] From [data$] Order by [Region]"
    closeRS
    OpenDB
    cmbRegion.Clear

    rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
    If rs.RecordCount > 0 Then
        Do While Not rs.EOF
            cmbRegion.AddItem rs.Fields(0)
            rs.MoveNext
        Loop
    Else
        MsgBox "I was not able to find any unique Region(s).", vbCritical + vbOKOnly
        Exit Sub
    End If
    '----------------------
    strSQL = "Select Distinct [Customer Type] From [data$] Order by [Customer Type]"
    closeRS
    OpenDB
    cmbCustomerType.Clear

    rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
    If rs.RecordCount > 0 Then
        Do While Not rs.EOF
            cmbCustomerType.AddItem rs.Fields(0)
            rs.MoveNext
        Loop
    Else
        MsgBox "I was not able to find any unique Customer Type(s).", vbCritical + vbOKOnly
        Exit Sub
    End If
End Sub

Answer 1

Per the comments, your OpenDB method is opening an ADO connection. You don't appear to be closing it anywhere.

You're attempting to reopen a connection that is already open. The OLE server error is telling you that the server (Excel) is busy because there is already another ADO connection attached to it. All you should need to do is make sure that you only open the connection once , and then close it when you are done working with it.

Answer 2

I've had a similar issue. This worked for me:
1. On the Tools menu, click Options.
2. Click the General tab.
3. Change the Ignore other applications that use Dynamic Data Exchange (DDE) check box, and then click OK.

I would only recommend changing this setting while working with your tutorial. While it solved this problem for me, it also caused Excel to behave strangely in some other circumstances.

If you think the issue is tied to your specific version of ADO you could also try using a reference to an older version (such as Microsoft ActiveX Data Objects 2.8 Library).

Answer 3

I just tested your code (Excel 2013 installed) and everything was fine though. No errors occured or something like that. I also checked the reference to the Microsoft ActiveX Data Objects Library and it is the ".tlb" for me too. So I think that this is not the problem.

But there is a problem that I think could be the reason for your error:

When your code line rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic is called the macro code could probably continue running and calling the next line while the SQL-query is not yet done. So calling the rs.RecordCount in the next line could result in an error if the query is still running.

As I was not able to reproduce your error, I can't to do further testing to solve your issue. So hopefully my idea might help you or anyone else to solve your problem.

Answer 4

This might be an old issue but my recent experience with this error:

Testers with my macro got this error and the issue was testers did not have modify access to the folder where workbook was opened and saved.