ADODB EXCEL SQL CopyFromRecordset to slow - sql

Question

I use VBA and ADODB Connection in Excel to realize VLOOKUP with SQL in attached code:
The Line "ThisWorkbook.Worksheets("result").Range("A1").CopyFromRecordset rs" takes to much time. Is there a way to use "INSERT INTO" in "strSQL" and skip "copyfromrecordset" instead to speedup the makro?
Sub vlookup()
Dim cn As Object
Dim rs As Object
Dim strConnection As String
Dim strSQL As String
Worksheets("result").UsedRange.Clear
Set cn = CreateObject("ADODB.CONNECTION")
strConnection = "DRIVER={MICROSOFT EXCEL DRIVER (*.xls, *.xlsx, *.xlsm, *.xlsb)}; DBQ=" & ThisWorkbook.FullName
With cn
.Open strConnection
strSQL = "SELECT table1$.*, table2$.price FROM [table1$] LEFT JOIN [table2$] ON table1$.animal = table2$.animal"
Set rs = CreateObject("ADODB.RECORDSET")
With rs
.Source = strSQL
.ActiveConnection = strConnection
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open
ThisWorkbook.Worksheets("result").Range("A1").CopyFromRecordset rs
.Close
End With
End With
cn.Close
Set cn = Nothing
Set rs = Nothing
End Sub

Answer 1

Found this question while struggling with legacy code which had CopyFromRecordSet. In my experience, it is horribly slow for anything more than a trivial number of lines.
Try extracting the Recordset information into 2D Variant Array and set the Value property of the respective Excel Range. Chunk your data if you think memory is going to be a constraint. The solution is involved. You'll need to do the bounds checks and also transpose the data before setting the Value property. Full answer below (without chunking):
Sub CopyFromRecordset(rngStart As Range, rstData As Variant)
Dim buffer As Variant
Dim i As Long, j As Long
If InStr(TypeName(rstData), "RecordSet") > 0 Then
rstData.MoveLast
rstData.MoveFirst
buffer = rstData.GetRows(rstData.RecordCount)
ReDim buffer2(UBound(buffer, 2), UBound(buffer, 1)) As Variant
For i = 0 To UBound(buffer, 1)
For j = 0 To UBound(buffer, 2)
buffer2(j, i) = buffer(i, j)
Next j
Next i
rngStart.Application.Range(rngStart, rngStart.Offset(UBound(buffer2, 1), UBound(buffer2, 2))).Value = buffer2
Else
Debug.Print ("Expected RecordSet, found " & TypeName(rstData))
End If
End Sub
Sub vlookup()
Dim cn As Object
Dim rs As Object
Dim strConnection As String
Dim strSQL As String
Worksheets("result").UsedRange.Clear
Set cn = CreateObject("ADODB.CONNECTION")
strConnection = "DRIVER={MICROSOFT EXCEL DRIVER (*.xls, *.xlsx, *.xlsm, *.xlsb)}; DBQ=" & ThisWorkbook.FullName
With cn
.Open strConnection
strSQL = "SELECT table1$.*, table2$.price FROM [table1$] LEFT JOIN [table2$] ON table1$.animal = table2$.animal"
Set rs = CreateObject("ADODB.RECORDSET")
With rs
.Source = strSQL
.ActiveConnection = strConnection
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open
CopyFromRecordset ThisWorkbook.Worksheets("result").Range("A1"), rs
.Close
End With
End With
cn.Close
Set cn = Nothing
Set rs = Nothing
End Sub