sqlexcelvbams-access

Import recordset from Access to VBA ListBox


sorry for the simple question but I am still a novice of VBA and Access.

I am trying to run a query in Access, then I need to import the output of this query to a listbox which has been created using Excel. The lisbox will have several columns (less than 10).

This is the code I am running:

'Set the name of the query you want to run and retrieve the data
Query = "SELECT [05_REQUESTED_ITEM].Manufacturer, [05_REQUESTED_ITEM].Quantity, [05_REQUESTED_ITEM].Description, [05_REQUESTED_ITEM].Application, [06_ITEM_DETAILS].Item, [06_ITEM_DETAILS].MAT_RFQ, [06_ITEM_DETAILS].Dimensions, [06_ITEM_DETAILS].Component, [06_ITEM_DETAILS].Part FROM (01_INPUT_DATA LEFT JOIN 05_REQUESTED_ITEM ON [01_INPUT_DATA].[SPET_ID] = [05_REQUESTED_ITEM].[SPET_ID]) LEFT JOIN 06_ITEM_DETAILS ON [01_INPUT_DATA].[SPET_ID] = [06_ITEM_DETAILS].[SPET_ID] WHERE ((([01_INPUT_DATA].SPET_ID)='" & ID & "'));"

On Error Resume Next

'Create the ADODB recordset object
Set rs = New ADODB.Recordset

'Check if the object was created.
If Err.Number <> 0 Then
    
    'Error! Release the objects and exit
    Set rs = Nothing
    Set cnt = Nothing
    
    'Display an error message to the user
    MsgBox "Recordset was not created!", vbCritical, "Recordset Error"
    
    Exit Function

End If

On Error Resume Next 'GOTO 0
         
'Set the cursor location and type, the lock type and the options
rs.CursorLocation = 2 ' = adUseServer '3 = adUseClient on early  binding
rs.CursorType = 2 ' = adOpenDynamic '1 = adOpenKeyset on early  binding
    
'Open the recordset
rs.Open Source:=Query, _
    ActiveConnection:=cnt
    
'Check if the recordset is empty
If rs.EOF And rs.BOF Then
    MsgBox "hello", vbOKOnly
    'Release the object
    Set rs = Nothing

Else
    
    'Explore the recordset
    rs.MoveFirst
    'ReadData = rs.GetRows
    
    With SEARCH_TOOL.SA_Result_Item_ListBox
        .Clear
        .ColumnCount = rs.Fields.Count
        For i = 0 To .ColumnCount
            ReadData = rs.GetRows(i)
            .List(i) = Application.WorksheetFunction.Transpose(ReadData)
        Next i
    End With
    
End If

What I find very strange is the fact that a very similar code is working when I populate the listbox with a query which has only one column of result as output.

How can I adapt my code to display in the listbox the full output divided in columns?

Thank you in advance for your time and support!


Solution

  • You can think of the List-property of a listbox as a 2-dimensional array. There are different ways to fill it:

    In your case, the first method is easier. You can get all data of the recordset into an 2-dimensional array with the method rs.GetRows (you have the statement already in your code, but you have commented it out).

    Unfortunately, the dimensions of that array are "wrong": The first dimension is the field, the second is the row (both dimensions are 0-based). ReadData(0, 3) is the value of the first field of the 4th row. The List expects the data vice versa (row in first dimension, fields in second). Therefore, you need to transpose the data:

    Dim readData As Variant
    readData = rs.GetRows
    
    With SEARCH_TOOL.SA_Result_Item_ListBox
       .Clear
       .ColumnCount = rs.Fields.Count
       .List = WorksheetFunction.Transpose(readData)
    End With
    

    Now there is only one problem: If your data may contain null-Values, WorksheetFunction.Transpose will throw an error. In that case I recommend to write a small helper function to do your transpose the data. I had issues with the data type Decimal, so I added an extra check for that.

    Function myTranspose(data As Variant) As Variant
    
        ReDim transposedData(LBound(data, 2) To UBound(data, 2), LBound(data, 1) To UBound(data, 1))
        Dim i As Long, j As Long
        For i = LBound(data, 1) To UBound(data, 1)
            For j = LBound(data, 2) To UBound(data, 2)
                If IsNull(data(i, j)) Then
                    transposedData(j, i) = vbNullString
                ElseIf VarType(data(i, j)) = vbDecimal Then
                    transposedData(j, i) = CLng(data(i, j))
                Else
                    transposedData(j, i) = data(i, j)
                End If
            Next j
        Next i
        myTranspose = transposedData
    
    End Function
    

    Then, your code could look like this instead

       .Clear
       .ColumnCount = rs.Fields.Count
       .List = myTranspose(readData)