Excel VBA copyfromrecordset复制超过100列时速度变慢

Question

i'm trying to use the code below to copy data from a sql (2008 r2) table to multiple sheets in excel 2003 - there are currently c420000 records, expanding at around 1000 a week. this is the requirement, i have no option to use access or later versions of excel for the output. i have been searching for some time and can find many threads on different forums relating to the same or similar issues but nothing specific enough to meet my requirements or help me resolve the issue.

what happens is the code will work but slows noticeably after around 30000 rows. i think the issue is the fact there are over 100 columns - i tested the code by selecting 6 or 7 columns and it returns a full dataset as required within an acceptable time period.

the code slows/hangs at the copyfromrecordset stage. if i break out of the code an error (-2147467259; Method 'CopyFromRecordset' of object 'Range' failed) is given but the code hasn't actually failed (yet), ie it can be continued without major issues.

i have not been able to complete the code for the full recordset and the longest i have let it run (2 hours) only completed around 50% - 60%.

can anybody shed any light on how i might be able to negate the problem with the process as it stands grinding to a painfully slow pace or suggest another method i might use? any help/suggestions gratefully appreciated

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

You can usually get quite a reasonable speed with ADODB like so:

''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