Save mySQL table to array and assign to worksheet - Excel VBA - mysql

Question

I have adapted some code I found to extract a mySQL table and write it to a worksheet. However, it is slow for some of the larger tables(30,000+). I am trying to find a better way to import the values and avoid looping. I was hoping to be able to assign it directly to a range, but have been unsuccessful. From my research, it seems Excel is limited when it comes to mySQL. Any suggestions?
Dim password As String
Dim sqlstr As String
Dim dbTable As String
'OMIT Dim Cn statement
Dim server_Name As String
Dim user_ID As String
Dim database_Name As String
Dim lRow As Integer, lCol As Integer
'Start timer
Dim Count As Long
Dim BenchMark As Double
BenchMark = Timer
Application.ScreenUpdating = False
Application.EnableEvents = False
'OMIT Dim rs statement
Set rs = CreateObject("ADODB.Recordset") 'EBGen-Daily
server_Name = Sheet10.Range("b1").Value
database_Name = Sheet10.Range("b2").Value ' Name of database
user_ID = Sheet10.Range("b3").Value 'id user or username
password = Sheet10.Range("b4").Value 'Password
dbTable = Sheet10.Range("tbl_name").Value
sqlstr = "SELECT * FROM " & dbTable
Set cn = New ADODB.Connection
'On Error Goto ErrorHandler
cn.Open "DRIVER={MySQL ODBC 8.0 Unicode Driver};" & _
"SERVER=" & server_Name & ";" & _
"DATABASE=" & database_Name & ";" & _
"USER=" & user_ID & ";" & _
"PASSWORD=" & password & ";" & _
"Option=16427"
rs.Open sqlstr, cn, adOpenStatic
'MsgBox cn.Execute("SELECT COUNT(*) As row_count FROM elite_advocacy;")!row_count + 1
Dim myArray()
myArray = rs.GetRows()
kolumner = UBound(myArray, 1)
rader = UBound(myArray, 2)
'Delete existing table
On Error Resume Next
Sheet2.ListObjects("tbl_data").Delete
On Error GoTo 0
'Write array to sheet <<< Slow for large datasets
For k = 0 To kolumner ' Using For loop data are displayed
Sheet2.Range("rng_s_data").Offset(0, k).Value = rs.Fields(k).Name
For r = 0 To rader
Sheet2.Range("rng_s_data").Offset(r + 1, k).Value = myArray(k, r)
Next
Next
'Write array to range <<< Failed
'Attempt 2
'Dim r1 As Range, rBase As Range
'Dim L As Long, U As Long
'Set rBase = Sheet2.Range("rng_s_data")
'L = LBound(myArray)
'U = UBound(myArray)
'r1 = rBase.Resize(1, rader - kolumner + 1)
'r1 = myArray
'Find lRow and lCol
lRow = Cells(Rows.Count, Range("rng_s_data").Column).End(xlUp).Row
lCol = Cells(Range("rng_s_data").Row, Columns.Count).End(xlToLeft).Column
'Create a table from Data
'Sheet2.ListObjects.Add(xlSrcRange, Sheet2.Range("A$5:$Z$100"), , xlYes).Name = "tbl_data"
Sheet2.ListObjects.Add(xlSrcRange, Sheet2.Range(Sheet2.Cells(Sheet2.Range("rng_s_data").Row, Sheet2.Range("rng_s_data").Column), _
Sheet2.Cells(lRow, lCol)), , xlYes).Name = "tbl_data"
Sheet2.ListObjects("tbl_data").TableStyle = "TableStyleLight1"
'Autofit Sheet
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True
'End Timer
MsgBox Timer - BenchMark
Errorhandler:
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub

Answer 1

I don't have mySQl for testing, but something like this would be a generic approach to querying any database from Excel using ADO.
Performance is optimum if you avoid any looping which involves cell-by-cell access, and do as much as you can with arrays, before transferring the final array to the worksheet in a single operation.
It's worth putting in extra effort to create re-usable pieces of code as standalone Subs or Functions - that allows your main logic to stay focused on the task at hand.
Sub Tester()
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim sql As String, dbTable As String, data, rngTbl As Range
Dim BenchMark As Double
BenchMark = Timer
Set cn = GetConnection()
Set rs = New ADODB.Recordset
dbTable = Sheet10.Range("tbl_name").Value
sql = "SELECT * FROM " & dbTable
rs.Open sql, cn, adOpenStatic
data = RecordSetToArray(rs) 'Includes field names
'data = RecordSetToArray(rs,False) 'False = no field names
'Delete existing table
On Error Resume Next
sheet2.ListObjects("tbl_data").Delete
On Error GoTo 0
'put the data on the worksheet
Set rngTbl = ArrayToSheetRange(data, sheet2.Range("rng_s_data"))
With sheet2.ListObjects.Add(xlSrcRange, rngTbl, , xlYes)
.Name = "tbl_data"
.TableStyle = "TableStyleLight1"
.Range.EntireColumn.AutoFit
End With
Debug.Print "Done in " & Timer - BenchMark
End Sub
'return an opened connection object
Function GetConnection() As ADODB.Connection
Dim serverNm As String, userId As String, dbNm As String, pw As String
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
serverNm = Sheet10.Range("b1").Value
dbNm = Sheet10.Range("b2").Value ' Name of database
userId = Sheet10.Range("b3").Value 'id user or username
pw = Sheet10.Range("b4").Value 'Password
cn.Open "DRIVER={MySQL ODBC 8.0 Unicode Driver};" & _
"SERVER=" & serverNm & ";" & _
"DATABASE=" & dbNm & ";" & _
"USER=" & userId & ";" & _
"PASSWORD=" & pw & ";" & _
"Option=16427"
Set GetConnection = cn
End Function
'Create a 2-D array from a recordset
Function RecordSetToArray(rs As ADODB.Recordset, _
Optional IncludeFieldNames As Boolean = True)
Dim tmp, nC As Long, nR As Long, data, r As Long, c As Long, rowNum As Long
tmp = rs.GetRows() 'cols x rows
nC = UBound(tmp, 1) + 1 'zero-based --> 1-based
nR = UBound(tmp, 2) + 1
ReDim data(1 To nR + IIf(IncludeFieldNames, 1, 0), 1 To nC) 'allow for headers?
If IncludeFieldNames Then
For c = 1 To nC
data(1, c) = rs.Fields(c - 1).Name
Next c
rowNum = 1
End If
For r = 1 To nR
rowNum = rowNum + 1
For c = 1 To nC
data(rowNum, c) = tmp(c - 1, r - 1)
Next c
Next r
RecordSetToArray = data
End Function
'Fill an array to a worksheet starting at `rng`, and return the filled range
Function ArrayToSheetRange(data, rng As Range) As Range
Dim rv As Range
Set rv = rng.Cells(1).Resize(UBound(data, 1), UBound(data, 2))
rv.Value = data
Set ArrayToSheetRange = rv
End Function