Excel UDF to return array from ACE SQL recordset

[JacekKotowski]

Dear Colleagues. I am trying to use ACE sql to return array from recordset. The function works well with table ranges.

Problem: the function returns the right number of records if the query returns 2 or more records. However if only one record is found, all rows are filled repetitively with this one row. This is wrong but I cannot find the reason why.

In addition, I wish my function would return column names from Recordset. I found some code, that could do it (commented out) but I have no idea how to glue it together with the array returned from recordset.

Here is the code, credits are due to the author of another solution that I am trying to adapt to my needs: Performing SQL queries on an Excel Table within a Workbook with VBA Macro

Thank you in advance for all the comments and help

Function SQL(dataRange As Range, CritA As String) As Variant
Application.Volatile

Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim currAddress As String

currAddress = ActiveSheet.Name & "$" & dataRange.Address(False, False)

strFile = ThisWorkbook.FullName
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open strCon


strSQL = "SELECT * FROM [" & currAddress & "]" & _
         "WHERE [A] =  '" & CritA & "'  " & _
         "ORDER BY 1 ASC"

rs.Open strSQL, cn

'SQL = rs.GetString
SQL = Application.Transpose(rs.GetRows)
  

Set rs = Nothing
Set cn = Nothing



End Function

 

[RickXL]

Hi,

As far as I know, I don't have access to any ACE data so I have tested this by using a different first half of the code.

If there is a slicker way of processing the arrays I don't know what it is but at least this is fairly obvious. Basically, I re-shape the array with the headings to make it two dimensional to match the data array. The output array size is known so this is preset with the ReDim statement then it is filled from the header and data arrays. Transposing happens at the same time.

You probably don't need the final write of the output array to Sheet2 but It may be useful so I have left it in.

Function SQL(dataRange As Range, CritA As String) As Variant
    Application.Volatile
    
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim currAddress As String
    Dim varHdr As Variant, varDat As Variant, varOut As Variant
    Dim nc As Long, nr As Long, i As Long, j As Long
    
    currAddress = ActiveSheet.Name & "$" & dataRange.Address(False, False)
    
    strFile = ThisWorkbook.FullName
    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
    & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
    
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    rs.CursorLocation = adUseClient ' required to return the number of rows correctly
    cn.Open strCon
    
    strSQL = "SELECT * FROM [" & currAddress & "]" & _
             "WHERE [A] =  '" & CritA & "'  " & _
             "ORDER BY 1 ASC"
    
    rs.Open strSQL, cn
    
    ' Process Column Headings
    nc = rs.Fields.Count
    ReDim varHdr(nc - 1, 0)
    For i = 0 To rs.Fields.Count - 1
        varHdr(i, 0) = rs.Fields(i).Name
    Next

    ' Get Rows from the Recordset
    nr = rs.RecordCount
    varDat = rs.GetRows

    ' Combing Header and Data and Transpose
    ReDim varOut(0 To nr, 0 To nc - 1)
    For i = 0 To nc - 1
        varOut(0, i) = varHdr(i, 0)
    Next
    For i = 1 To nr
        For j = 0 To nc - 1
            varOut(i, j) = varDat(j, i - 1)
        Next
    Next

    ' Write Output Array to Sheet2
    With Sheet2
        .Cells.Clear
        .Range("A1").Resize(nr, nc) = varOut
    End With
      
    
    Set rs = Nothing
    Set cn = Nothing

End Function

 

[JacekKotowski]

Thank you. It works like a charm.

I don't have access to any ACE data so I have tested this by using a different first half of the code.

The function works in excel as a multi-cell array function (Ctrl+Shift+Enter) and it takes a table object or a range in Excel sheet as input, queries it and returns a recordset (my ACE sql data )

The Access runtime (ACE SQL) does the job of filtering and aggregating datal. I just did not like to repeat vlookup or sumif a couple of thousand times to join two tables or to aggregate them.

 

[RickXL]

Good news and thanks for the feedback.

The function works in excel as a multi-cell array function ...

That sounds interesting. I am going to have to try that. I see now why you wanted the answer in an array. I did wonder about that.

I find that I can answer many questions here without looking too hard at what the code is trying to do. So I took one look at "ACE" and decided to use a known, working bit of code instead.

I never thought of writing UDFs that worked as array functions. I have learnt something new so thank you for that. I feel some experimentation coming on

Just for completeness. This is how I tested your additions:

Option Explicit
Sub xx()
    Dim wsData As Worksheet, rData As Range
    Dim DataLocn As String
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    Dim SQL As String
    Dim varHdr As Variant, varDat As Variant, varOut As Variant
    Dim nc As Long, nr As Long, i As Long, j As Long
    
    Set wsData = Worksheets("Sheet1")
    
    ' Define range of original data
    Set rData = wsData.UsedRange
    DataLocn = rData.Worksheet.Name & "$" & rData.Address(False, False)
    
    ' Summarize data
    Dim sConn As String
    On Error GoTo err
    sConn = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & ThisWorkbook.Path & "\Recordset - Array.xlsm"
    rs.CursorLocation = adUseClient
    rs.Open "SELECT * FROM [" & DataLocn & "] WHERE [x1]>5", sConn
    On Error GoTo 0
    
    ' Process Column Headings
    nc = rs.Fields.Count
    ReDim varHdr(nc - 1, 0)
    For i = 0 To rs.Fields.Count - 1
        varHdr(i, 0) = rs.Fields(i).Name
    Next

    ' Get Rows from the Recordset
    nr = rs.RecordCount
    varDat = rs.GetRows

    ' Combing Header and Data and Transpose
    ReDim varOut(0 To nr, 0 To nc - 1)
    For i = 0 To nc - 1
        varOut(0, i) = varHdr(i, 0)
    Next
    For i = 1 To nr
        For j = 0 To nc - 1
            varOut(i, j) = varDat(j, i - 1)
        Next
    Next

    ' Write Output Array to Sheet2
    With Sheet2
        .Cells.Clear
        .Range("A1").Resize(nr, nc) = varOut
    End With
    
    Set rs = Nothing
    Exit Sub
    
    ' Error reporting from SQL step
err:
    MsgBox err.Description + " " + err.Source, vbCritical, "Import"
    err.Clear
    Application.ScreenUpdating = True
End Sub