Say Goodbye to QueryTables

We started with the QueryTable object in order to ease into this subject.  It’s time to say farewell to QueryTable and fully embrace ADO.  I’m using ADO, not because it’s the best, but because it is compatible with everything my customers have and (I’m guessing) with 98% of all current XL installs, and because the coding for ADO is nearly identical to the older DAO and other newer database access methods available to VBA.  So as technology progresses, our code needn’t change drastically.

We are replacing the QueryTable object with a call to another function that snaps into our code.  The function looks very much like the SQLRead function from the last post.  Here it is:

Function SQLLoad(sSQL As String, _
                 sConnect As String, _
                 sRange As String, _
                 Optional sSheet As String, _
                 Optional sName As String, _
                 Optional iTimeOut As Integer, _
                 Optional bAppend As Boolean) As Boolean

'   SQLLoad:     Loads an XL Range with data from a database table/file

'   Parameters:  sSQL        SQL Select statement
'                sConnect    Connection String
'                sRange      upper left cell address (ex. "A5") to put data
'                sSheet      worksheet to receive data
'                sName       name to give the retuned data
'                iTimeout    milliseconds to wait for a result before quitting
'                bAppend     Set to true to append data to a previous result

'   Example:     bResult =  SQLLoad("Select * From QUSRSYS/QAEZDISK", _
'                                   "DRIVER={iSeries Access ODBC Driver};" & _
'                                   "SYSTEM=10.0.0.3;NAM=1;", _
'                                   "A4","Data","Data",300,False )

'     Date   Init Modification
'   01/01/01 CWH  Initial Programming

    On Error GoTo ErrHandler
    SQLLoad = Failure           'Assume Something went wrong

    Dim cn As ADODB.Connection  'Connection Object
    Dim rs As ADODB.Recordset   'Recordset Object
   
    Dim lRows As Long           'Number of Rows in Range
    Dim lCols As Long           'Number of Columns in Range
    Dim l As Long               'Generic long variable
   
    Settings "Save"             'Save XL Settings
    Settings "Disable"          'Disable screen updates, etc.
   
 '  Print the start time and SQL string in VBA's immediate window
    Debug.Print "Start:", Time, sSQL
   
 '  Clear spreadsheet if this is not appending to existing data
    If Not bAppend Then
        If sSheet > " " Then
            Worksheets(sSheet).Activate
            If ClearAll(sSheet) Then GoTo ErrHandler
        End If
    End If
                    
'   Create Connection and Recordset Objects
    Set cn = New ADODB.Connection
    cn.Properties("Prompt") = adPromptComplete
    cn.Open sConnect, "", ""
    Set rs = New ADODB.Recordset
   
'   Restrict how long the query can run before failing
    If iTimeOut > 0 Then
        cn.CommandTimeout = iTimeOut
    End If
   
'   Get the data from the database
    rs.Open sSQL, cn
      
    With Range(sRange)
        lCols = rs.Fields.Count
'       Add column headings (if not appending)
        If Not bAppend Then
            For l = 0 To lCols - 1
                .Cells(1, l + 1) = rs(l).Name
                .Cells(1, l + 1).Font.Bold = True
            Next l
            l = 2
'       Position to end of data to append to
        Else
            lRows = Range(sName).Rows.Count - 1
        End If
'       Read Recordset and copy to XL
        While Not rs.EOF
            lRows = lRows + .Cells(lRows + 2, 1).CopyFromRecordset(rs, 10000)
            If Not rs.EOF Then lRows = lRows - 1
        Wend
'       Resize columns to fit data
        Cells.EntireColumn.AutoFit
'       Create a name for the data
        If sName > " " Then Names.Add sName, Range(.Cells(1, 1), _
            .Cells(lRows + 1, lCols))
    End With
       
 '  Set column headings to repeat at top of page on printouts
    ActiveSheet.PageSetup.PrintTitleRows = "$" & Range(sRange).Row & _
                                          ":$" & Range(sRange).Row
       
 '  Print the end time in VBA's immediate window
    Debug.Print "End:", Time
   
    SQLLoad = Success

ErrHandler:
   
    If Err.Number <> 0 Or cn.Errors.Count <> 0 Then
        SQLLoad = Failure
        If Err.Number <> 0 Then
            MsgBox "SQLLoad - Error#" & Err.Number & vbCrLf & Err.Description, _
                vbCritical, "Error", Err.HelpFile, Err.HelpContext
        Else
            Dim errLoop As ADODB.Error
            For Each errLoop In cn.Errors
                MsgBox "SQLLoad - Error number: " & errLoop.Number & vbCr & _
                    errLoop.Description, vbCritical, "Error", errLoop.HelpFile, _
                    errLoop.HelpContext
            Next errLoop
        End If
    End If
    On Error Resume Next
    If rs.State > 0 Then rs.Close   'Close Recordset
    If cn.State > 0 Then cn.Close   'Close Connection
    Settings "Restore"              'Restore XL Settings
    On Error GoTo 0
   
End Function 

Here is the modified MACRO1() with the QueryTable replaced.  Note that it looks similar, and cleaner.

Sub Macro1()

    Dim s As String
    Dim sSQL As String
    Dim sConnect As String
  
    s = Trim( _
             InputBox("Enter State Code:" & vbCr & vbCr & _
                 "'%' is a wildcard.  By itself it will retrieve all states. " & _
                 "'N%' will retrieve all states beginning with 'N'" & vbCr & _
                 "'%Y' will retrieve all states ending in 'Y'", _
                 "State Code Prompt", "%") _
            )
   
    If s > "" Then
        sConnect = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};" & _
                   "DBQ=C:\Users\chatmaker\Documents\Northwind 2007.accdb;"
           
        sSQL = "SELECT O.`Order ID`, O.`Customer ID`, " & vbCr & _
               "       O.`Order Date`, C.`First Name`, " & vbCr  & _
               "       O.`Ship State/Province`, D.Quantity, " & vbCr & _
               "       P.`Product Name` " & vbCr & _
               "FROM   Customers C, Orders O, " & vbCr & _
               "       `Order Details` D, Products P " & vbCr & _
               "WHERE  O.`Customer ID` = C.ID " & vbCr & _
               "  AND  O.`Order ID`    = D.`Order ID` " & vbCr & _
               "  AND  D.`Product ID`  = P.ID " & vbCr & _
               "  AND  C.`State/Province` LIKE '" & s & "'"
       
        SQLLoad sSQL, sConnect, "A4", "Data", "Data"
       
        Pivot_Template       
    End If
   
End Sub

How to Copy Code from this Blog to XL

1. Open your XL spreadsheet containing modGeneral.
2. Get to the VBE (Alt-F11)
3. Open modGeneral in the Code Window
4. From this post, select and copy the code
5. Paste into the Code Window (*see next paragraph)
6. Make any corrections to code that didn’t paste correctly
7. From the VBE menu navigate File > Export File…
8. Save modGeneral and remember where you saved it.

Unfortunately, the code won’t paste 100% properly.  You will have to add carriage returns and perhaps fix a few things until your code looks exactly like what you see here.