Export using CopyFromRecordset

tuktuk

Well-known Member
Joined
Nov 13, 2006
Messages
856
Hey there,

I use the following vba code to export a string to an excel file. it is 25K rows and takes approx 20min. is there anyway to alter the code to speed this up?

Code:
Set dbs = CurrentDb()
Set rst = dbs.OpenRecordset(strExport, dbOpenDynaset, dbReadOnly)

If rst.EOF = False And rst.BOF = False Then
      rst.MoveFirst
      If blnHeaderRow = True Then
            For lngColumn = 0 To rst.Fields.Count - 1
                  xlc.Offset(0, lngColumn).Value = rst.Fields(lngColumn).Name
            Next lngColumn
            Set xlc = xlc.Offset(1, 0)
      End If

'write data to worksheet
xlc.CopyFromRecordset rst
End If

rst.Close
Set rst = Nothing

dbs.Close
Set dbs = Nothing
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

xenou

MrExcel MVP
Joined
Mar 2, 2007
Messages
16,831
Office Version
  1. 2019
Platform
  1. Windows
CopyFromRecordset is usually very fast (a few seconds is what I would expect here). Hard to tell but it seems likely that the reason for the slowdown is elsewhere in this process -- something before or after this particular code is called.

ξ

Just to confirm, copying 50000 rows with 10 columns is more or less instantaneous:

Code:
Sub foo()
Dim rs As DAO.Recordset
Dim XL As Object
Dim wb As Object

    Set rs = CurrentDb.OpenRecordset("SELECT * FROM Table1;")
    Set XL = CreateObject("Excel.Application")
    Set wb = XL.Workbooks.Open("C:\Users\Kermit\Desktop\Book1.xlsx")
    With wb
        .Worksheets(1).Cells(1).CopyFromRecordset rs
        .Save
        .Close False
    End With
    XL.Quit
    Set XL = Nothing

End Sub

Note: If your paste initiates calculations in Excel that can be another cause of delay - while Excel recalculates due to the new data coming in...
 
Last edited:

tuktuk

Well-known Member
Joined
Nov 13, 2006
Messages
856
i'm still struggling....actaully was not able to get your to post quickly either

here is my total code....i step through a table to gather the variables

Code:
Private Sub foo_TG()

DoCmd.SetWarnings False
Dim rsExport As Recordset
Dim i As Integer
        
Set rsExport = CurrentDb.OpenRecordset("qry_Export_Step_Thru")
Dim flds As DAO.Fields
Dim fld As DAO.Field

Dim strExport As String
Dim strSheetName As String
Dim strCellRef As String
Dim strheader As String

Set flds = rsExport.Fields
Set fld = flds("qryName")
        
Set fldsWSName = rsExport.Fields
Set fldWSName = fldsWSName("SheetName")

Set fldsCellRef = rsExport.Fields
Set fldCellRef = fldsCellRef("CellRef")

Set fldsHeader = rsExport.Fields
Set fldHeader = fldsHeader("Header")

With rsExport
    .MoveFirst
    
Do While Not .EOF
    strExport = fld
    strSheetName = fldWSName
    strCellRef = fldCellRef
    strheader = fldHeader

Dim lngColumn As Long
Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim blnEXCEL As Boolean, blnHeaderRow As Boolean

blnEXCEL = False

blnHeaderRow = strheader

On Error Resume Next
Set xlx = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
      Set xlx = CreateObject("Excel.Application")
      blnEXCEL = True
End If
Err.Clear
On Error GoTo 0

xlx.Visible = True

Set xlw = xlx.Workbooks.Open("C:\Desktop\Template.xlsm")

xlw.Application.Calculation = xlManual
xlw.Application.DisplayAlerts = False
Set xls = xlw.Worksheets(strSheetName)
    
Set xlc = xls.Range(strCellRef) ' this is the first cell into which data go

Set dbs = CurrentDb()

Set rst = dbs.OpenRecordset(strExport, dbOpenDynaset, dbReadOnly)

If Not rst Is Nothing Then
If rst.EOF = False And rst.BOF = False Then
      rst.MoveFirst
      If blnHeaderRow = True Then
            For lngColumn = 0 To rst.Fields.Count - 1
                  xlc.Offset(0, lngColumn).Value = rst.Fields(lngColumn).Name
            Next lngColumn
            Set xlc = xlc.Offset(1, 0)
      End If
        xlc.CopyFromRecordset rst
End If

rst.Close
Set rst = Nothing

dbs.Close
Set dbs = Nothing

Set xlc = Nothing
Set xls = Nothing

xlw.Application.Calculation = xlAutomatic
xlw.Application.DisplayAlerts = True

xlw.Close True
Set xlw = Nothing
If blnEXCEL = True Then xlx.Quit
Set xlx = Nothing
    
    .MoveNext
Loop
End With

End Sub

do i have my refeerences set prop?
VBA or app
MS Access 12.0 obj lib
OLE Auto
MS DAO 3.6
MS ActiveX Data Obj 2.8 lib
MS Excel 12.0

thansk
Tuk
 

xenou

MrExcel MVP
Joined
Mar 2, 2007
Messages
16,831
Office Version
  1. 2019
Platform
  1. Windows
At first glance looks okay. How many times do you run through this loop when this executes (i.e., how many records are in the first query qry_Export_Step_Thru)?
 

tuktuk

Well-known Member
Joined
Nov 13, 2006
Messages
856

ADVERTISEMENT

actually it only has one record in the table that feeds all the strings.....i copied it from a more extensive module.

that is what is wierd.....even after attemping to use your code provided it still was extremely slow....or i should say i interupted it becasue it was longer than 5 min.

any other ideas?
 

xenou

MrExcel MVP
Joined
Mar 2, 2007
Messages
16,831
Office Version
  1. 2019
Platform
  1. Windows
I would try stepping through the code (Put the cursor on the first line in the VBA editor and hit F8 to move one line at a time). The behavior can be different when run this way, but possibly you will see what line it's getting "stuck" on.
 

tuktuk

Well-known Member
Joined
Nov 13, 2006
Messages
856

ADVERTISEMENT

yep did that already on your code and mine as well...both get hung of the CopyFromRecordset line.......crazy. Sort of lost on what else to do on this one. it lieterally takes approx 20 min after headers are pasted.
 

tuktuk

Well-known Member
Joined
Nov 13, 2006
Messages
856
i did stop the process of the export and got this error after selecting debug

Method 'CopyFromRecordset' of object 'Range' Failed

hmmm somewhere my range rst is off?
 

xenou

MrExcel MVP
Joined
Mar 2, 2007
Messages
16,831
Office Version
  1. 2019
Platform
  1. Windows
It's hard to say without knowing what you are copying/copying to. Could fail if the range wasn't set, or other issues (data doesn't fit on worksheet, worksheet is protected).

The code could be simplified - you don't need to open/close excel repeatedly. And I don't trust GetObject() because it seems buggy to me (I've never satisfactorily found it to work as advertised) - just open a new instance of Excel to use during your procedure.

Code:
[COLOR="Navy"]Sub[/COLOR] foo_TG()
[COLOR="Navy"]Dim[/COLOR] i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] AppXL [COLOR="Navy"]As[/COLOR] Object, wb [COLOR="Navy"]As[/COLOR] Object, ws [COLOR="Navy"]As[/COLOR] Object, rng [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Object[/COLOR]
[COLOR="Navy"]Dim[/COLOR] rsOuter [COLOR="Navy"]As[/COLOR] DAO.Recordset
[COLOR="Navy"]Dim[/COLOR] rs [COLOR="Navy"]As[/COLOR] DAO.Recordset
blnHeaderRow [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Boolean[/COLOR]


    [COLOR="Navy"]Set[/COLOR] AppXL = CreateObject("Excel.Application")
    [COLOR="Navy"]With[/COLOR] AppXL
        [COLOR="Navy"]Set[/COLOR] wb = .Workbooks.Open("C:\Desktop\Template.xlsm")
        .Calculation = -4135 [COLOR="SeaGreen"]'//Manual[/COLOR]
        .DisplayAlerts = False
    [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
    AppXL.Visible = True
    
    
    [COLOR="Navy"]Set[/COLOR] rsOuter = CurrentDb.OpenRecordset("qry_Export_Step_Thru")
    [COLOR="Navy"]With[/COLOR] rsOuter
        
        [COLOR="Navy"]Do[/COLOR] [COLOR="Navy"]While[/COLOR] [COLOR="Navy"]Not[/COLOR] .EOF
            
            [COLOR="Navy"]Set[/COLOR] ws = wb.Worksheets(.Fields("SheetName").Value)
            [COLOR="Navy"]Set[/COLOR] rng = ws.Range(.Fields("CellRef").Value)    [COLOR="SeaGreen"]' this is the firs cell into which data go[/COLOR]
            blnHeaderRow = IIf(Nz(.Fields("Header").Value) <> "", True, False)
            [COLOR="Navy"]Set[/COLOR] rs = CurrentDb.OpenRecordset(.Fields("qryName").Value, dbOpenDynaset)
            
            [COLOR="Navy"]If[/COLOR] [COLOR="Navy"]Not[/COLOR] rs.EOF [COLOR="Navy"]Then[/COLOR]
                
                [COLOR="Navy"]If[/COLOR] blnHeaderRow = True [COLOR="Navy"]Then[/COLOR]
                    [COLOR="Navy"]For[/COLOR] i = 0 [COLOR="Navy"]To[/COLOR] rs.Fields.Count - 1
                        rng.Offset(0, i).Value = rs.Fields(i).Name
                    [COLOR="Navy"]Next[/COLOR] i
                    [COLOR="Navy"]Set[/COLOR] rng = rng.Offset(1, 0)
                [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
                rng.CopyFromRecordset rs
                wb.Save
            
            [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]

            .MoveNext
        
        [COLOR="Navy"]Loop[/COLOR]
        
    [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
        
    AppXL.Calculation = -4105 [COLOR="SeaGreen"]'//Automatic[/COLOR]
    wb.Close False
    AppXL.Quit
        
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

While stepping through your code you would want to check the values for the sheet name, cell ref, headers ... etc. (Or run the query and print the results so you can "follow along").
 

Watch MrExcel Video

Forum statistics

Threads
1,129,917
Messages
5,638,981
Members
417,061
Latest member
thematulaak

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top