Running a Database Query

[fredlo2010]

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/libr...=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]

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]

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