Excel copyfromrecordset very slow

[Teckstein]

I am pulling data from an access database. The query in Access runs in a few seconds, but it takes over 6 minutes to run this code. I am just a starter, so this is code that I have pieced together from examples throughout the web.

Sub EditionMetricScores()


Application.StatusBar = "Query initiatied"
Application.Calculation = xlCalculationManual



'Step 1: Declare your variables
Dim MyDatabase As DAO.Database
Dim MyQueryDef As DAO.QueryDef
Dim MyRecordset As DAO.Recordset
Dim i As Integer
Dim MyLocation As String

' get database location from spreadsheet
Sheets("Scores").Select
MyLocation = Range("b1").Value

'Step 2: Identify the database and query
Set MyDatabase = DBEngine.OpenDatabase _
(MyLocation)
Set MyQueryDef = MyDatabase.QueryDefs("qryEdition-MetricScores")

'Step 3: Define the Parameters

With MyQueryDef
.Parameters("[edition-year]") = Range("c4").Value
End With

'Step 4: Open the query
Set MyRecordset = MyQueryDef.OpenRecordset

Application.StatusBar = "clear data area"

'Step 5: Clear previous contents
Sheets("AccessData").Select
ActiveSheet.Range("a7:g2000").ClearContents

Application.StatusBar = "copy recordset"
'Step 6: Copy the recordset to Excel
ActiveSheet.Range("A7").CopyFromRecordset MyRecordset

'Step 7: Add column heading names to the spreadsheet
' skip this step because it is so slow - and i don't erase the headers from query to query
'For i = 1 To MyRecordset.Fields.Count
'ActiveSheet.Cells(6, i).Value = MyRecordset.Fields(i - 1).Name
'Next i

Application.StatusBar = "Obtain metric weights"
'------------------------
'get metric weights
'-----------------------
' select query
Set MyQueryDef = MyDatabase.QueryDefs("qryEdition_weights")

'set parameter
Sheets("Scores").Select
With MyQueryDef
.Parameters("[Edition-year]") = Range("c4").Value
End With

'clear prior content
Sheets("AccessData").Select
ActiveSheet.Range("m6:z100").ClearContents

' open the recordset
Set MyRecordset = MyQueryDef.OpenRecordset

'copy recordset to excel
ActiveSheet.Range("m7").CopyFromRecordset MyRecordset

'add column headings
For i = 1 To MyRecordset.Fields.Count
ActiveSheet.Cells(6, i + 12).Value = MyRecordset.Fields(i - 1).Name
Next i


'return to left side of sheet
Sheets("Scores").Select
ActiveSheet.Range("A1").Select
'final step - send message

Application.StatusBar = ""
Application.Calculation = xlCalculationAutomatic

'message box that times out after 2 seconds
CreateObject("wscript.shell").popup "Click Ok or wait 2 seconds", 1, "Query Complete"

End Sub

Thanks for any suggestions. (I left in all the statusbar changes as it showed that the copy recordset command was the very slow one.)

 

[Teckstein]

I have resolved this issue by breaking the database query into numerous smaller queries which run much faster than the one in the original script.