title: excel vba copyfromrecordset slows when copying over 100 columns
body: <p>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.</p>
  
  <p>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.</p>
  
  <p>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.</p>
  
  <p>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%.</p>
  
  <p>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</p>
  
  <pre class="lang-vb prettyprint-override"><code>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 &amp; 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;" &amp; _
          "Data Source=SOMESERVER;" &amp; _
          "Initial Catalog=SomeDatabase;" &amp; _
          "Integrated Security=SSPI"
  
  ' identify frequecy for reporting and build SQL
  ' daily data is live records only
  If Frequency = "daily" Then
      sSQL = "SELECT * " &amp; _
              "FROM tblMainTabWithFlagsDaily " &amp; _
              "WHERE status='LIVE';"
  Else
      'weekly - all records split over multiple sheets
      sSQL = "SELECT *" &amp; _
              "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" &amp; Format(lWScount + 1, "0#")    ' shouldn't need numerous sheets for live data - ave 15k - 16k records
                  Else
                      .Name = "Split" &amp; 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
  </code></pre>