Excel VBA copyfromrecordset復制超過100列時速度變慢

Question

我正在嘗試使用下面的代碼在excel 2003中將數據從sql（2008 r2）表復制到多張工作表-當前有c420000條記錄，每周擴展約1000條。 這是必需的，我沒有選擇將訪問或更高版本的excel用於輸出。 我已經搜尋了一段時間，可以在不同的論壇上找到許多與相同或相似問題相關的主題，但是沒有足夠的細節可以滿足我的要求或幫助我解決該問題。

發生的事情是該代碼可以運行，但是在大約30000行之后速度明顯降低。 我認為問題是存在超過100列的事實-我通過選擇6或7列測試了代碼，並在可接受的時間內按要求返回了完整的數據集。

代碼在copyfromrecordset階段變慢/掛起。 如果我超出代碼范圍，則會給出錯誤（-2147467259；對象“ Range”的方法“ CopyFromRecordset”失敗），但代碼實際上尚未失敗（尚未），即可以繼續進行而不會出現重大問題。

我無法完成完整記錄集的代碼，而我讓它運行的最長時間（2小時）僅完成了大約50％-60％。

有人能闡明我如何解決該過程中存在的問題，因為它的步伐緩慢而緩慢，或者建議我使用其他方法嗎？ 任何幫助/建議表示感謝

Sub DATA_Import(Frequency As String)

Dim sCon As String                  ' building string for the connection property
Dim sSQL As String                  ' building string for the SQL property
Dim rsData As ADODB.Recordset       ' reference made to latest ADO library - 2.8
Dim cnxEWMS As ADODB.Connection     ' reference made to latest ADO library - 2.8
Dim lWScount As Long
Dim lRow As Long, lCol As Long      ' holders for last row & col in data
Dim c As Range                      ' identifies where flags data begins - should be constant but you never know!
Dim Cx As Long                      ' for looping through the flags columns to change blanks to 0
Dim wbNew As Workbook               ' the final destination file!
Dim sFileDate As String             ' the date for naming the output file
Dim wsNotes As Worksheet            ' notes sheets for product
Dim wsCover As Worksheet            ' cover sheet for product

Worksheets("Headings").Cells.Delete


' using windows authentication
' won't work where user is not listed on SQL server
sCon = "Provider=SQLOLEDB;" & _
        "Data Source=SOMESERVER;" & _
        "Initial Catalog=SomeDatabase;" & _
        "Integrated Security=SSPI"

' identify frequecy for reporting and build SQL
' daily data is live records only
If Frequency = "daily" Then
    sSQL = "SELECT * " & _
            "FROM tblMainTabWithFlagsDaily " & _
            "WHERE status='LIVE';"
Else
    'weekly - all records split over multiple sheets
    sSQL = "SELECT *" & _
            "FROM tblMainTabWithFlagsDaily;"
End If


' create and open the connection to the database
Set cnxEWMS = New ADODB.Connection
With cnxEWMS
    .Provider = "SQLOLEDB;"
    .ConnectionString = sCon
    .Open
End With

' create and open the recordset
Set rsData = New ADODB.Recordset
rsData.Open sSQL, cnxEWMS, adOpenForwardOnly, adLockReadOnly

With Application
    ' if construct used for debugging/testing when called from module1
    If Not TestCaller Then
        .ScreenUpdating = False
    End If
    .Calculation = xlCalculationManual
End With

    If Not rsData.EOF Then
        ' create header row 'dummy' sheet
        For lCol = 0 To rsData.Fields.Count - 1
            With Worksheets("Headings").Range("A1")
                .Offset(0, lCol).Value = rsData.Fields(lCol).Name
            End With
        Next

        Set c = Worksheets("Headings").Rows("1:1").Cells.Find("warrflag_recno")

        ' copy data into workbook and format accordingly
        Do While Not rsData.EOF

            If wbNew Is Nothing Then
                ' create the new "product" workbook
                Worksheets("Headings").Copy
                Set wbNew = ActiveWorkbook
            Else
                lWScount = wbNew.Worksheets.Count
                ThisWorkbook.Worksheets("Headings").Copy after:=wbNew.Worksheets(lWScount)
            End If

            With wbNew.Worksheets(lWScount + 1)
                .UsedRange.Font.Bold = True
                If Frequency = "daily" Then
                    .Name = "Live" & Format(lWScount + 1, "0#")    ' shouldn't need numerous sheets for live data - ave 15k - 16k records
                Else
                    .Name = "Split" & Format(lWScount + 1, "0#")
                End If

            ' THE REASON WE'RE ALL HERE!!!
            ' copy from recordset in batches of 55000 records
            ' this keeps hanging, presumably because of number of columns
            ' reducing columns to 6 or 7 runs fine and quickly
            .Range("A2").CopyFromRecordset rsData, 55000

        ' the remainder of the code is removed 
        ' as it is just formatting and creating notes 
        ' and cover sheets and then saving

' tidy up!
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

rsData.Close
Set rsData = Nothing
cnxEWMS.Close
Set cnxEWMS = Nothing
Set c = Nothing
Set wsNotes = Nothing
Set wsCover = Nothing

End Sub

Answer 1

通常，使用ADODB可以獲得相當合理的速度，如下所示：

''The data source z:\docs\test.accdb is not used, it is only there to get a 
''working string.
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=z:\docs\test.accdb"

cn.Open strCon

''This selects into an existing workbook with a new sheet name, any name that does
''not already exist will work. The ODBC connection to SQL Server is whatever you 
''use for ODBC connection.
ssql = "SELECT * INTO [Excel 8.0;HDR=YES;DATABASE=Z:\Docs\Test.xlsx].[Sheet7] " _
     & "FROM [ODBC;DRIVER=SQL Server Native Client 11.0;SERVER=localhost\SQLEXPRESS; " _
     & "DATABASE=MyDB;Trusted_Connection=Yes;].MyTable"

cn.Execute ssql