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

Question

我正在尝试使用Excel作为数据库,我正在关注此站点的教程.

问题是,每当我尝试在下面的文件中"更新Drop Downs"时,我都会收到此错误:"Microsoft正在等待另一个应用程序完成OEL操作".

我在这里错过了什么或做错了什么,我该如何做到这一点？

我正在使用Excel 2016家庭和学生,这是最新的.我在打开工作簿时也启用了宏.

在Excel 2007中打开时,同一文件运行完美.我还注意到Microsoft ActiveX Data Objects 6.0库在示例中引用了"msado60.dll",而在Excel 2016中它是一个"msado60.tlb"文件(我在使用).

链接到Excel文件

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

根据评论，您的OpenDB方法正在打开 ADO 连接。您似乎没有在任何地方关闭它。

您正在尝试重新打开已打开的连接。OLE 服务器错误告诉您服务器 (Excel) 正忙，因为已经有另一个 ADO 连接连接到它。您需要做的就是确保仅打开连接一次，然后在使用完毕后将其关闭。