VBA Listas dependientes con Combo Boxes no acepta valores

Status
Not open for further replies.

Armando Aldaz

New Member
Joined
Jul 21, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Hola a todos!
He descargado el siguiente archivo, el cual contiene un listado de articulos.
1626977137832.png


El archivo contiene un Userform el cual despliega una lista dependiente en cuanto el puntero es ubicado en cada una de las casillas (Muy útil)
1626977149224.png


El problema resulta cuando dicha tabla o información de orginen es reemplazada, como en este caso por el ejemplo de partidas presupuestarias, en la que al colocar un valor numerico, como se puede apreciar en la imagen en la columa D "Amount"
1626977543060.png


En cuanto se da click al boton "Clear" (Command Button 1) envia la siguiente alerta "Run-time error '91': Object variable or With block variable not set.", esto al detectar que es un valor numerico.

El codigo de VBA esta estructurado de la siguiente manera, y en Negritas marcare donde se encuentra el error o debug.


Dim con As Object
Dim rs As Object
Dim sql As String

Private Sub ComboBox1_Change()
If Not ComboBox1.Text = "" Then
Call Listbox
Call Combo(sql)
End If

End Sub

Private Sub ComboBox2_Change()
If Not ComboBox2.Text = "" Then
Call Listbox
Call Combo(sql)
End If

End Sub

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Me.ComboBox1.DropDown
End Sub

Private Sub ComboBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Me.ComboBox2.DropDown
End Sub
Private Sub ComboBox3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Me.ComboBox3.DropDown
End Sub
Private Sub ComboBox4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Me.ComboBox4.DropDown
End Sub
Private Sub ComboBox3_Change()
If Not ComboBox3.Text = "" Then
Call Listbox
Call Combo(sql)
End If
End Sub
Private Sub ComboBox4_Change()
If Not ComboBox4.Text <> "" Then
Call Listbox
Call Combo(sql)
End If
End Sub
Private Sub CommandButton1_Click()
Set con = Nothing

ComboBox1 = Empty
ComboBox2 = Empty
ComboBox3 = Empty
ComboBox4 = Empty
ListBox1.Clear
Call Userform_initialize
End Sub




Private Sub CommandButton2_Click()
Dim sat As Long, sut As Byte, s2 As Worksheet, bu As Long

If ListBox1.ListCount = 0 Then
MsgBox "There Aren't Data", vbExclamation
Exit Sub
End If
Sheets("FilteredData").Activate
Sheets("FilteredData").Range("A:D").Clear
Set s2 = Sheets("FilteredData")
sat = ListBox1.ListCount
sut = ListBox1.ColumnCount
bu = s2.Range("A" & Rows.Count).End(xlUp).Row + 1

s2.Range("A" & bu & ":D" & sat + bu - 1) = ListBox1.List
MsgBox "The Data Was Copied."
Set s2 = Nothing
End Sub

'*****
Private Sub Userform_initialize()
Set con = CreateObject("adodb.connection")
#If VBA7 And Win64 Then
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.FullName & ";extended properties=""excel 12.0;hdr=no"""
#Else
con.Open "provider=Microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.FullName & ";extended properties=""excel 8.0;hdr=no"""
#End If

Call Combo("")
End Sub
'*****

Sub Listbox()
sql = "select * from [Data$A2:D1000] Where F1 is not null"
If ComboBox1.Text <> "" Then sql = sql & " and f1 = '" & ComboBox1.Value & "'"
If ComboBox2.Text <> "" Then sql = sql & " and f2 = '" & ComboBox2.Value & "'"
If ComboBox3.Text <> "" Then sql = sql & " and f3 = '" & ComboBox3.Value & "'"
If ComboBox4.Text <> "" Then sql = sql & " and f4 = '" & ComboBox4.Value & "'"
Set rs = con.Execute(sql) '(Aqui esta el problema)
ListBox1.ColumnCount = rs.Fields.Count
ListBox1.Column = rs.GetRows(rs.RecordCount)

End Sub

Sub Combo(ByVal Tablo As String)
If Tablo = "" Then Tablo = "[Data$A:D]"
ComboBox1.Column = con.Execute("select distinct F1 from (" & Tablo & ")").GetRows
ComboBox2.Column = con.Execute("select distinct F2 from (" & Tablo & ")").GetRows
ComboBox3.Column = con.Execute("select distinct F3 from (" & Tablo & ")").GetRows
ComboBox4.Column = con.Execute("select distinct F4 from (" & Tablo & ")").GetRows
End Sub

Espero puedan apoyarme con esta consulta.
Gracias de antemano!

A.ALDAZ
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
65,998
Office Version
  1. 365
Platform
  1. Windows
Duplicate to: VBA Cascading Dependent Drop Down Lists does not accept values

In future, please do not post the same question multiple times. Per Forum Rules (#12), posts of a duplicate nature will be locked or deleted.

In relation to your question here, I have closed this thread so please continue in the linked thread. If you do not receive a response, you can "bump" it by replying to it yourself, though we advise you to wait 24 hours before doing so, and not to bump a thread more than once a day.
 
Status
Not open for further replies.

Forum statistics

Threads
1,148,250
Messages
5,745,645
Members
423,965
Latest member
visionquest1972

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top