。copyfromrecordset没有响应

Question

我有以下代码，该代码是从电子表格数据库中复制数据的，该电子表格数据库已与该电子表格数据库建立了连接并将其粘贴到活动工作簿中。它检查6种情况，并根据情况为特定工作表打开一个记录集。

对于6例中的5例，这种方法非常有效。对于第六种情况，该行：

ThisWorkbook.Sheets("JobOrders").Range("A2").CopyFromRecordset objRecordset

使Excel约15-20秒不响应，然后它将继续执行后记。我对此完全不知所措。我认为以下是所有相关代码。

        Set objConnection = CreateObject("ADODB.Connection")
        Set objRecordset = CreateObject("ADODB.Recordset")
        Set objFSO = CreateObject("Scripting.filesystemobject")
        dbFile = dbPath & SheetArr(i)
        Set objFile = objFSO.getfile(dbFile)
        objConnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & dbFile & ";Extended Properties=""Excel 12.0 Xml;HDR=Yes;IMX=0"";"
        ...
        Case Is = 4
            objRecordset.Open "Select * FROM [Database$]", objConnection
            ThisWorkbook.Sheets("Database").Range("A2").CopyFromRecordset objRecordset
            ThisWorkbook.Sheets("Database").Cells.WrapText = False
            Application.CutCopyMode = False
            objRecordset.Close
            objConnection.Close
            ThisWorkbook.Sheets("Contacts").Cells(1, 17).value = Now
        Case Is = 5
            objRecordset.Open "Select * FROM [Documents$]", objConnection
            ThisWorkbook.Sheets("Documents").Range("A2").CopyFromRecordset objRecordset
            ThisWorkbook.Sheets("Documents").Cells.WrapText = False
            Application.CutCopyMode = False
            objRecordset.Close
            objConnection.Close
            ThisWorkbook.Sheets("Contacts").Cells(1, 8).value = Now
        Case Is = 6
            objRecordset.Open "Select * FROM [JobOrders$]", objConnection
            ThisWorkbook.Sheets("JobOrders").Range("A2").CopyFromRecordset objRecordset
            ThisWorkbook.Sheets("JobOrders").Cells.WrapText = False
            Application.CutCopyMode = False
            objRecordset.Close
            objConnection.Close
            ThisWorkbook.Sheets("Contacts").Cells(1, 29).value = Now
    End Select
End If
Next i

任何帮助将不胜感激！让我知道您是否需要更多或有任何疑问！

Answer 1

虽然您的情况不太可复制，但可能是如何使对象正确化的问题。考虑使用DRY-er方法，因为您似乎正在嵌套运行For，If和Select。

• 由于所有Case块实际上是相同的，因此仅将它们用于分配SQL语句，工作表名称和联系表列号
• 将数据库对象objConncection和objRecordset彼此靠近，并在需要的查询和输出任务后打开/关闭
• 使用With块避免重复对象并更好地组织方法和属性
• 尝试使用Set obj = Nothing释放所有对象

重构代码

For i = ...
    ...
    If ...
        myConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                 "Data Source=" & dbFile & _
                 ";Extended Properties=""Excel 12.0 Xml;HDR=Yes;IMX=0"";"

        Select Case ...
            ...
            Case Is = 4
                mySql = "Select * FROM [Database$]"
                mySheet = "Database"
                myContactCol = 17

            Case Is = 5
                mySql = "Select * FROM [Documents$]"
                mySheet = "Documents"
                myContactCol = 8

            Case Is = 6
                mySql = "Select * FROM [JobOrders$]"
                mySheet = "JobOrders"
                myContactCol = 29

        End Select

        objConnection.Open myConn                       ' OPEN CONNECTION
        objRecordset.Open mySql                         ' OPEN RECORDSET
        With ThisWorkbook.Sheets(mySheet)
            .Range("A2").CopyFromRecordset objRecordset
            .Cells.WrapText = False
        End With
        objRecordset.Close                              ' CLOSE RECORDSET
        objConnection.Close                             ' CLOSE CONNECTION

        ThisWorkbook.Sheets("Contacts").Cells(1, myContactCol).value = Now
        Application.CutCopyMode = False

        ' RELEASE SET OBJECTS
        Set objFile = Nothing: Set objFSO = Nothing
        Set objRecordset = Nothing: Set objConnection = Nothing
    End If
Next i