[RESOLVED] Excel VBA - Populating A Multi-Column Listbox

For reasons I don't want to go into, I can't use a ListView for this. My only option is a multicolumn ListBox.

I have one on a userform. It has 14 columns and I need to populate it based on a recordset created from a query against an Access database table.

I have Googled this and found tons and zillions of examples of how to populate such an animal that is on a worksheet from data in cells on the worksheet but I didn't find anything on how to slap numerous rows of multicolumn data from a recordset.

Also, is there a better way of creating column headers than using labels positioned above the listbox?

Hack, Try this. Please amend the code as applicable.

Code:

---

'~~> Please set a reference to the Microsoft ActiveX Data Objects x.x Library!
Option Explicit

'~~> Database Name
Const mdbPath = "C:\Hack.mdb"
'~~> Connection String
Const strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & mdbPath & ";"

Dim cn      As New ADODB.Connection
Dim rs      As New ADODB.Recordset
Dim MyArray As Variant
Dim sSQL    As String
   
Private Sub CommandButton1_Click()
    sSQL = "SELECT * from Table1"
   
    cn.Open strCon
       
    '~~> Open recordset and copy to an array
    rs.Open sSQL, cn
   
    MyArray = rs.GetRows
   
    '~~> Update listbox
    With Me.ListBox1
        .Clear
        .ColumnCount = 5 '<~~ Column Count as Applicable
        .List = Application.Transpose(MyArray)
        .ListIndex = -1
    End With
   
    '~~> Close and cleanup
    rs.Close
    cn.Close
    Set rs = Nothing
    Set cn = Nothing
End Sub

---

Quote:

---

Also, is there a better way of creating column headers than using labels positioned above the listbox?

---

Not that I am aware of.

Sid

Thanks Sid. I did kinda get it to work on my own, but it is real sloppy. I like your approach but I'm getting a type mismatch error on the highlight line.

Code:

---

Dim adoRS As ADODB.Recordset
Dim sSQL As String
Dim myArray As Variant
sSQL = "My Query String here which works fine"
Set adoRS = New ADODB.Recordset
adoRS.Open sSQL, ADOCn  'ADOCn is my connection object created and executed elsewhere

myArray = adoRS.GetRows
   
    '~~> Update listbox
    With Me.ListBox1
        .Clear
        .ColumnCount = 14 '<~~ Column Count as Applicable
        .List = Application.Transpose(myArray) 'Error 13 Type Mismatch here
        .ListIndex = -1
    End With

adoRS.Close
Set adoRS = Nothing

---

Ah! that depends on the data. If you change that line to

.List = myArray

Does it populate the data? The orientation might be OFF though.

Sid

The other way is to dimension the array and then fill the array from the rs in a loop and then simply use

.List = myArray

Sid

Well this is interesting.

I changed the line of code to .List = myArray

When I run a query that I know will bring back just one record, it puts all 14 items (0 through 13) into column 1

When I run a query that I know will bring back multiple records, it populates the first three columns and then starts a new row and populates three columns and starts a new row and populates three columns etc. :lol:

I have the columncount set to 14 in both the property page and in code.

On the other hand, this code does work for multiple records. The problem is it will only go to 9 columns.

On column 10 I get an Error 380 “Could not set the List property. Invalid Property value.” Error

Code:

---

'query and other things are here
Set adoRS = New ADODB.Recordset
adoRS.Open sSQL, ADOCn
Do While Not adoRS.EOF
'myArray = adoRS.GetRows
   
    '~~> Update listbox
'    With Me.ListBox1
'        .Clear
'        .ColumnCount = 14 '<~~ Column Count as Applicable
'        .List = myArray
'        '.List = Application.Transpose(myArray)
'        .ListIndex = -1
'    End With

  ListBox1.AddItem adoRS(0)
  ListBox1.List(i, 1) = adoRS(1)
  ListBox1.List(i, 2) = adoRS(2)
  ListBox1.List(i, 3) = adoRS(3)
  ListBox1.List(i, 4) = adoRS(4)
  ListBox1.List(i, 5) = adoRS(5)
  ListBox1.List(i, 6) = adoRS(6)
  ListBox1.List(i, 7) = adoRS(7)
  ListBox1.List(i, 8) = adoRS(8)
  ListBox1.List(i, 9) = adoRS(9)
'  ListBox1.List(i, 10) = adoRS(10) 'this line gives me the 380 error
  i = i + 1
  adoRS.MoveNext
Loop
adoRS.Close
Set adoRS = Nothing

---

Yes, that is a limitation when you use .AddItem.

See this link

http://www.pcreview.co.uk/forums/xl-...-t2857402.html

Did you try looping through the rs and then populating the multidimensional array as I suggested in #5? That ways you don't need to transpose and you will be able to use .List = myArray

If you can upload a sample database then maybe I can show you an example?

Sid

Quote:

---

Originally Posted by koolsid

The other way is to dimension the array and then fill the array from the rs in a loop and then simply use

---

Isn't that what myArray = rs.GetRows is doing?

Quote:

---

.List = Application.Transpose(myArray) 'Error 13 Type Mismatch here

---

try
.List = Application.worksheetfunction.Transpose(myArray)

Yes, but it is putting the values in vertical format (That is the reason we had to use transpose)

If we hard code the array then it will be easier to use it with the listbox :)

Edit
If you can give me a sample database then I can give you an example.

Sid

Try this (with header option in comments):

vb Code:

Private Sub CommandButton1_Click()
    Const sDBPath = "D:\Documents\VBF\Sample.mdb"
    Const sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDBPath & ";"
    Dim cn   As ADODB.Connection
    Dim rs   As ADODB.Recordset
    Dim sSQL As String
    Dim i    As Long
 
    Set cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    
    sSQL = "SELECT * FROM Plan"
    cn.Open sConn
    rs.Open sSQL, cn
    With Me.ListBox1
        .Clear
        .ColumnHeads = False
        If rs.EOF Then
            .ColumnCount = 1
            .AddItem "No record found"
        Else
            .ColumnCount = rs.Fields.Count
            '-- use .Column to dump data,
            '   don't use .List with Transpose() that also fails with single record
            .Column = rs.GetRows()
            '-- create fake column headers -----------
            .AddItem , 0 '-- add header row
            For i = 0 To rs.Fields.Count - 1
                .List(0, i) = rs.Fields(i).Name
            Next
            '-- To use sticky headers, recordset must be dumped to a sheet below a header row:
            '   Sheet1.Range("A2").CopyFromRecordset rs
            '-- then set:
            '   .ColumnHeads = True
            '   .Rowsource = "Sheet1!A2:S20" '--(exclude header row)
            '-----------------------------------------
            '-- set column widths as required:
            .ColumnWidths = "40;50;30;30;30;30;30;30;30;30;30;30;30;30;30;30;30;30;30;30;30;30"
            .TopIndex = 0 '-- scroll to top item
        End If
    End With
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
End Sub

This did it - all 14 columns

Code:

---

    With Me.ListBox1
        .Clear
        .ColumnHeads = False
        .ColumnCount = adoRS.Fields.Count
        .ColumnWidths = "20;50;50;190;80;170;50;80;120;80;80;80;80;80"
        .Column = adoRS.GetRows
        .ListIndex = -1
    End With

---

Thanks for the points Hack :)

You finally made me create a sample database :D

Here is what I was talking about...

Code:

---

Private Sub CommandButton1_Click()
    Const sDBPath = "C:\Hack.mdb"
    Const sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDBPath & ";"
    Dim cn  As ADODB.Connection
    Dim rs  As ADODB.Recordset
    Dim sSQL As String
    Dim i    As Long
    Dim Myarray() As String
   
    Set cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
   
    sSQL = "SELECT * FROM table1"
    cn.Open sConn
    rs.Open sSQL, cn, 1, 1
    With Me.ListBox1
        .Clear
        .ColumnHeads = False
        If rs.RecordCount < 1 Then
            .ColumnCount = 1
            .AddItem "No record found"
        Else
            .ColumnCount = rs.Fields.Count
            ReDim Myarray(rs.RecordCount, rs.Fields.Count)
            rw = 0
            Do While Not rs.EOF
                For i = 1 To rs.Fields.Count - 1
                    If IsNull(rs.Fields(i)) Then Myarray(rw, i) = "" Else _
                    Myarray(rw, i) = rs.Fields(i)
                Next
                rw = rw + 1
                rs.MoveNext
            Loop
            .List = Myarray
            .ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50"
            .TopIndex = 0
        End If
    End With
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
End Sub

---

@Anhn: I liked the way you added Column Headers :) Hope you and your family are okay in nz. Feeling bad about CChurch.

Sid

That works too.

However, in the event some new person tries to run the code and it returns a compile error on an undefined variable, just add: Dim rw As Integer :D

This was a great thread excel 2003 vba problems..populating a multicolumn listbox via ado and getting past the 10 .additem limitation !
Everything in this thread I had the same errors !


Thanks
fordraiders:wave: