PDA

View Full Version : Running a Database Query



fredlo2010
12-24-2014, 08:19 AM
Hello everyone and happy holidays! :)


I have a query-database question. Since this is more like and advice post I have made the questions bold.

I have a workbook that currently queries data from a database and its using procedure No1 to get the data. This gets the job don't without any problem most of the time; but sometimes when the sql takes a while to return the data Excel tends to crash.

I was think if using a ADO object combination of Connections and Recordsets will perform a little bit better. I have been using this in other macros and it's been working fine (small datasets returned).
http://msdn.microsoft.com/en-us/library/windows/desktop/ms675944%28v=vs.85%29.aspx

Will this object crash under a lot of records? I am talking about an array(200,41)


The problem with this second solution is that the headings can vary from procedure to procedure and I need the headings to identify other data.

Is there a way to create an array with the data and the headings?

Thanks a lot for your help and advice. :) :) :)

Procedure No1.


Dim oQueryTable As QueryTable
Dim strConnection As String


strConnection = "ODBC;DRIVER=SQL Server;" & _
"SERVER=myServer;" & _
"UID=myID;" & _
"PWD=myPass;" & _
"DATABASE=myDataBase"


Set oQueryTable = rDumpRange.Parent.QueryTables.Add(Connection:=strConnection, Destination:=rDumpRange)


With oQueryTable
.CommandText = QueryText
.Name = ReportName
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.Refresh BackgroundQuery:=False
End With

This is some code I have created for the ADO.


Option Explicit

Private Const m_intMYSQL As Integer = 1
Private Const m_intSQL As Integer = 2


Enum conType
conMySQL = m_intMYSQL
conSQL = m_intSQL
End Enum


Function GetConnection(eType As conType, _
ByVal strServer As String, _
ByVal strDataBase As String, _
ByVal strUser As String, _
ByVal strPassword As String) As Object

Dim oConn As Object
Dim strConn As String

On Error GoTo Error_Handler

' Instantiate the connection object
Set oConn = CreateObject("ADODB.Connection")

If eType = conMySQL Then
strConn = "Driver={MySQL ODBC 5.3 ANSI Driver};" & _
"Server=" & strServer & ";" & _
"Database=" & strDataBase & ";" & _
"User=" & strUser & ";" & _
"Password=" & strPassword & ";"



ElseIf eType = conSQL Then
strConn = "Provider=SQLOLEDB.1;" & _
"Data Source=" & strServer & ";" & _
"Initial Catalog=" & strDataBase & ";" & _
"User ID=" & strUser & ";" & _
"Password=" & strPassword & ";"
End If

' Try to open the connection.
oConn.Open strConn

Exit_Handler:
' If the connection opened succesfully return it
If oConn.State = 1 Then
Set GetConnection = oConn
Else
Set GetConnection = Nothing
End If

On Error GoTo 0

' Clean up
Set oConn = Nothing
Exit Function

Error_Handler:

' If the error is realted to the driver missing. Let the user know.
' Open internet and navigate to the code.
If Err.Number = -2147467259 Then
If MsgBox("Missing driver for connection." & vbCr & _
"Please download the following driver, install it and try again." & vbCr & vbCr & _
"Do you want to download the driver?", vbInformation + vbYesNo, "Missing Driver") = vbYes Then

Dim oInternet As Object

Set oInternet = CreateObject("INTERNETEXPLORER.APPLICATION")
oInternet.Navigate "http://dev.mysql.com/downloads/connector/odbc/"
oInternet.Visible = True

Set oInternet = Nothing
End If
Else
MsgBox Err.Description, vbInformation + vbOKOnly, "Error Connecting"
End If

Resume Exit_Handler



End Function


' Sample RecordSet
Function GetRecordSet(oConn As Object, ByVal strSQLCommand) As Object


Dim oRecordSet As Object
Dim oCmd As Object
Dim oParam As Object

On Error GoTo Error_Handler

Set oCmd = CreateObject("ADODB.Command")
Set oRecordSet = CreateObject("ADODB.Recordset")

With oCmd
Set .ActiveConnection = oConn
.CommandType = 1
.CommandText = strSQLCommand


Set oRecordSet = .Execute
End With

Exit_Handler:

If oRecordSet.State = 1 Then
Set GetRecordSet = oRecordSet
Else
Set GetRecordSet = Nothing
End If

On Error GoTo 0

' Clean up
Set oRecordSet = Nothing
Set oCmd = Nothing
Set oParam = Nothing


Exit Function

Error_Handler:


MsgBox "Error in: " & ThisWorkbook.VBProject.VBE.ActiveCodePane.CodeModule & vbCr & _
Err.Description, vbCritical

Resume Exit_Handler


End Function




Function TransposeBigArray(ByVal arrValues As Variant) As Variant

Dim ret() As Variant

Dim iDim1 As Long
Dim iDim2 As Long

' Expand the array to fit all the values
' Make it base 1 to match the range values.
ReDim ret(UBound(arrValues, 2), UBound(arrValues, 1))

For iDim1 = 0 To UBound(arrValues, 1)
For iDim2 = 0 To UBound(arrValues, 2)
ret(iDim2, iDim1) = arrValues(iDim1, iDim2)
Next iDim2
Next iDim1

Exit_Handler:


TransposeBigArray = ret

Exit Function
Error_Handler:

On Error GoTo 0
Resume Exit_Handler

End Function

:) :) :)

Kenneth Hobs
12-29-2014, 02:39 PM
Fred, you might be able to adapt something like what I posted in #8 of: http://www.vbaexpress.com/forum/showthread.php?51081

A Range's CopyFromRecordSet tends to work ok.

When writing to ranges, things can be sped up a bit by turning off screen updating and automatic calculation.
http://vbaexpress.com/kb/getarticle.php?kb_id=1035

cheers

fredlo2010
12-30-2014, 05:36 AM
Thanks for the response Kenneth.

I am using something similar currently, Note this uses some functions from my second block of code in Post#1



Public sub RunQuery(ByVal rDumpRange As Range)
Dim oConn As Object Dim oRecordSet As Object
Dim arrValues As Variant
Dim arrHeadings As Variant
Dim i As Long
Dim j As Long




Set oConn = GetConnection(conSQL, "SERVER", "DATABASE", "USER", "PASSWORD")
Set oRecordSet = GetRecordSet(oConn, QueryText)


' Copy the recordset to the sheet.'
If Not oRecordSet.EOF Then


ReDim arrHeadings(oRecordSet.fields.Count - 1)


For i = 0 To UBound(arrHeadings)
arrHeadings(i) = oRecordSet.fields(i).Name
Next i


' Add the records to the array
arrValues = oRecordSet.GetRows


' Use the transpose big array because of the limitation
' of Application.Transpose
arrValues = TransposeBigArray(arrValues)


' Place the values in the workbook
rDumpRange.Resize(1, UBound(arrHeadings) + 1).value = arrHeadings
rDumpRange.Offset(1).Resize(UBound(arrValues, 1) + 1, UBound(arrValues, 2) + 1).value = arrValues
End If


' Close the connection
oConn.Close




' Clean up
Set oRecordSet = Nothing
Set oConn = Nothing
End Sub


Thanks a lot