krolfes
asked on
populate Excel dropdown with Access data
How would I go about populating a dropdown list for a column of cells so it populates the list from a query returned from an Access table? Then based on what the user choooses, I want the index field to be stored in the cell rather than the description.
Thanks.
Thanks.
Sorry, here is the correct version
Sub usbGetListItems()
Dim dbe As DAO.DBEngine
Dim ws As DAO.Workspace
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim s As msforms.ComboBox
Dim i As Integer
Dim lstcount As Long
Dim varItem As Variant
Dim objControl As Object
On Error GoTo Err_usbGetListItems
Set dbe = New DAO.DBEngine
Set ws = dbe.Workspaces(0)
Set db = ws.OpenDatabase("D:\data\a ccess2k\Ge neral2k.md b")
Set rs = db.OpenRecordset("SELECT ID, Color FROM tblColors")
If rs.EOF = True And rs.BOF = True Then
Err.Raise 55000, "usbGetListItems", "No records were returned!"
Else
rs.MoveFirst
' This must be a combobox added from the "Control Toolbox" toolbar,
' not the one from the "Forms" Toolbar
Set objControl = Sheets("Sheet1").Shapes("C omboBox1") .OLEFormat .Object
Set s = objControl.Object
lstcount = s.ListCount
'remove all the items
Do Until lstcount = 0
s.RemoveItem 0
lstcount = lstcount - 1
Loop
'add new items
Do While Not rs.EOF
s.AddItem
s.Column(0, i) = rs.Fields("ID").Value
s.Column(1, i) = rs.Fields("Color").Value
rs.MoveNext
i = i + 1
Loop
End If
Exit_usbGetListItems:
On Error Resume Next
If Not rs Is Nothing Then rs.Close: Set rs = Nothing
If Not db Is Nothing Then db.Close: Set db = Nothing
If Not ws Is Nothing Then ws.Close: Set ws = Nothing
If Not dbe Is Nothing Then Set dbe = Nothing
If Not s Is Nothing Then Set s = Nothing
If Not objControl Is Nothing Then Set objControl = Nothing
Exit Sub
Err_usbGetListItems:
MsgBox "Error [" & Err.Number & "] " & Err.Source & vbCrLf & Err.Description, vbCritical, "usbGetListItems"
End Sub
Sub usbGetListItems()
Dim dbe As DAO.DBEngine
Dim ws As DAO.Workspace
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim s As msforms.ComboBox
Dim i As Integer
Dim lstcount As Long
Dim varItem As Variant
Dim objControl As Object
On Error GoTo Err_usbGetListItems
Set dbe = New DAO.DBEngine
Set ws = dbe.Workspaces(0)
Set db = ws.OpenDatabase("D:\data\a
Set rs = db.OpenRecordset("SELECT ID, Color FROM tblColors")
If rs.EOF = True And rs.BOF = True Then
Err.Raise 55000, "usbGetListItems", "No records were returned!"
Else
rs.MoveFirst
' This must be a combobox added from the "Control Toolbox" toolbar,
' not the one from the "Forms" Toolbar
Set objControl = Sheets("Sheet1").Shapes("C
Set s = objControl.Object
lstcount = s.ListCount
'remove all the items
Do Until lstcount = 0
s.RemoveItem 0
lstcount = lstcount - 1
Loop
'add new items
Do While Not rs.EOF
s.AddItem
s.Column(0, i) = rs.Fields("ID").Value
s.Column(1, i) = rs.Fields("Color").Value
rs.MoveNext
i = i + 1
Loop
End If
Exit_usbGetListItems:
On Error Resume Next
If Not rs Is Nothing Then rs.Close: Set rs = Nothing
If Not db Is Nothing Then db.Close: Set db = Nothing
If Not ws Is Nothing Then ws.Close: Set ws = Nothing
If Not dbe Is Nothing Then Set dbe = Nothing
If Not s Is Nothing Then Set s = Nothing
If Not objControl Is Nothing Then Set objControl = Nothing
Exit Sub
Err_usbGetListItems:
MsgBox "Error [" & Err.Number & "] " & Err.Source & vbCrLf & Err.Description, vbCritical, "usbGetListItems"
End Sub
ASKER
blakeh1,
I need to apply this dropdown to all cells in a column, so that when the user chooses any cell in the column, the dropdown may be chosen.
I need to apply this dropdown to all cells in a column, so that when the user chooses any cell in the column, the dropdown may be chosen.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Thank you Krolfes
Sébastien
Sébastien
ASKER
I just posted another question...can you help...
Hello, I have this problem in creating drop down lists based on External data reference included in other worksheets of the same file.
Data in the list is not refreshed as well as the data (query from Access) included in the other sheet.
Why..?
Data in the list is not refreshed as well as the data (query from Access) included in the other sheet.
Why..?
It queries an access database and populates the list box. An alternate apporach would be to create a MSQuery link to the db on another sheet and just use that as the ListRange value in the properties window. This sample uses a 2 column combobox, where the first column is the ID value and is not displayed. You would set the properties accordingly (I have ColumnCount = 2 and ColumnWidths = 0 pt;10 pt and my LinkedCell = Sheet1!A1)
Sub usbGetListItems()
Dim dbe As DAO.DBEngine
Dim ws As DAO.Workspace
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim s As msforms.ComboBox
Dim i As Integer
Dim lstcount As Long
Dim varItem As Variant
Dim objControl As Object
Set dbe = New DAO.DBEngine
Set ws = dbe.Workspaces(0)
Set db = ws.OpenDatabase("D:\data\a
Set rs = db.OpenRecordset("SELECT ID, Color FROM tblColors")
If rs.EOF = True And rs.BOF = True Then
Err.Raise 55000, "usbGetListItems", "No records were returned!"
Else
rs.MoveFirst
' This must be a combobox added from the "Control Toolbox" toolbar,
' not the one from the "Forms" Toolbar
Set objControl = Sheets("Sheet1").Shapes("C
Set s = objControl.Object
lstcount = s.ListCount
'remove all the items
Do Until lstcount = 0
s.RemoveItem 0
lstcount = lstcount - 1
Loop
'add new items
Do While Not rs.EOF
s.AddItem
s.Column(0, i) = rs.Fields("ID").Value
s.Column(1, i) = rs.Fields("Color").Value
rs.MoveNext
i = i + 1
Loop
End If
Exit_usbGetListItems:
On Error Resume Next
If Not rs Is Nothing Then rs.Close: Set rs = Nothing
If Not db Is Nothing Then db.Close: Set db = Nothing
If Not ws Is Nothing Then ws.Close: Set ws = Nothing
If Not dbe Is Nothing Then Set dbe = Nothing
If Not s Is Nothing Then Set s = Nothing
If Not objControl Is Nothing Then Set objControl = Nothing
Err_usbGetListItems:
MsgBox "Error [" & Err.Number & "] " & Err.Source & vbCrLf & Err.Description, vbCritical, "usbGetListItems"
End Sub