复制超过100列时，excel vba copyfromrecordset变慢
我试图用下面的代码将数据从一个sql（2008 r2）表复制到excel 2003中的多个工作表 – 目前有c420000logging，每周扩展到1000个左右。 这是要求，我没有select使用访问或更高版本的Excel输出。 我一直在寻找一些时间，可以在不同的论坛上find许多关于相同或类似问题的主题，但没有足够的具体内容来满足我的要求或帮助我解决问题。
代码会发生什么事情，但大约30000行后会明显减慢。 我认为问题是有超过100列的事实 – 我通过select6或7列testing代码，并在可接受的时间段内根据需要返回完整的数据集。
代码在copyfromrecordset阶段放慢/挂起。 如果我打破了代码错误（-2147467259;对象'范围'的方法'CopyFromRecordset'失败）给出，但代码还没有实际上失败（还），即它可以继续没有重大问题。
我没有能够完成全部logging的代码，并且我已经让它运行了最长的时间（2小时），只完成了大约50％ – 60％。
任何人都可以阐明我怎样才能消除这个过程中的问题，因为它磨损到一个痛苦的缓慢的步伐，或者build议我可能使用的另一种方法？ 任何帮助/build议感激地赞赏
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 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