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