复制超过 100 列时，excel vba copyfromrecordset 变慢

Question

我正在尝试使用下面的代码将数据从 sql (2008 r2) 表复制到 excel 2003 中的多个工作表中 - 目前有 c420000 条记录，每周增加约 1000 条。这是要求，我无法选择使用 access 或更高版本的 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