Código para Combobox anidado a otro y Listbox
Me podrían ayudar con el código necesario para filtrar los datos de dos combobox y un listbox de un userform con el siguiente ejemplo:
Hoja: Productos
Columna A: Código Producto
Columna B: No. Parte
Columna C: Nombre Producto
Columna D: Descripción
Columna E: Línea de Negocio
Columna F: Grupo Insumo
La fila 1 Contienen los encabezados
Los productos están agrupados por la columna E – Línea de Negocio y dentro de esta por la columna F Grupo de Insumo.
Ejemplo:
Línea de Negocio: ELectrico
Grupo de Insumo: Cable – Tomas – Luminarias
Línea de Negocio: Comunicaciones
Grupo de Insumo: Cobre – Fibra Óptica – Patch Cord
Si en el combobox1 selecciono Eléctrico, el combo2 debe contener únicamente Cable – Tomas – Luminarias
Y el ListBox deberá arrojar la selección de los productos que contengan estas condiciones.
Por su ayuda y colaboración mil
1 respuesta
Crea un formulario con dos combobox y 1 listbox y agrega al formulario el siguiente código, luego crea una tabla de productos empezando en la celda A1 y corres la macro, esta llenara el combobox 1 con los datos de la línea de negocio, luego en el combobox 2 se cargaran el grupo de insumos y por ultimo el el listbox se cargara solo lo filtrado en los dos combobox, por cierto crea una hoja llamada hoja2 hay se copiara lo filtrado antes de cargarse al listbox esto porque es la única forma de que la información en el listbox salga con encabezados.
Private Sub ComboBox1_Change()
Dim FUNCION As WorksheetFunction
Dim UNICOS As New Collection
Set FUNCION = WorksheetFunction
Set PRODUCTOS = Range("PRODUCTOS")
LINEA = ComboBox1.Value
With PRODUCTOS
FILAS = .Rows.Count
columnas = .Columns.Count
cuenta = FUNCION.CountIf(.Columns(columnas - 1), LINEA)
INDICE = FUNCION.Match(LINEA, .Columns(columnas - 1), 0)
Set INSUMOS = .Rows(INDICE).Resize(cuenta)
End With
ComboBox2.Clear
ListBox1.RowSource = Empty
With INSUMOS
FILAS = .Rows.Count
columnas = .Columns.Count
For I = 1 To FILAS
insumo = .Cells(I, columnas)
On Error Resume Next
UNICOS.Add insumo, CStr(insumo)
If Err.Number = 0 Then ComboBox2.AddItem insumo
On Error GoTo 0
Next I
.Name = "INSUMOS"
End With
Set FUNCION = Nothing: Set PRODUCTOS = Nothing
End Sub
Private Sub ComboBox2_Change()
Dim FUNCION As WorksheetFunction
Set FUNCION = WorksheetFunction
Set INSUMOS = Range("INSUMOS")
insumo = ComboBox2.Value
If insumo = Empty Then GoTo sal
With INSUMOS
FILAS = .Rows.Count
columnas = .Columns.Count
cuenta = FUNCION.CountIf(.Columns(columnas), insumo)
INDICE = FUNCION.Match(insumo, .Columns(columnas), 0)
Set TABLA = .Rows(INDICE).Resize(cuenta)
End With
With Sheets("HOJA2")
.Cells.Clear
TABLA.Copy: .Range("A3").PasteSpecial xlPasteValues
Range("PRODUCTOS").Rows(1).Copy: .Range("A2").PasteSpecial xlPasteValues
Set destino = .Range("a2").CurrentRegion
With destino
Set destino = .Rows(2).Resize(cuenta)
End With
With ListBox1
.RowSource = "hoja2!" & destino.Address
.ColumnCount = columnas
.ColumnHeads = True
End With
End With
set destino=nothing: set insumos=nothing: set funcion=nothing
sal:
End Sub
Private Sub UserForm_Activate()
With UserForm1
.Caption = "MODULO DE PRODUCTOS"
.Move 150, 10
End With
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub UserForm_Initialize()
Set PRODUCTOS = Range("A1").CurrentRegion
With PRODUCTOS
.Sort KEY1:=Range(.Columns(5).Address), ORDER1:=1, _
KEY2:=Range(.Columns(6).Address), ORDER2:=1, _
Header:=xlYes
.Name = "PRODUCTOS"
End With
LINEAS_UNICAS
Set PRODUCTOS = Nothing
End Sub
Sub LINEAS_UNICAS()
Set PRODUCTOS = Range("PRODUCTOS")
With PRODUCTOS
FILAS = .Rows.Count
columnas = .Columns.Count
.Columns(columnas + 3).CurrentRegion.Clear
Set UNICOS = .Columns(columnas + 3).Resize(FILAS, 1)
.Columns(5).Copy
End With
With UNICOS
.PasteSpecial xlValues
.RemoveDuplicates Columns:=1
FILAS = .CurrentRegion.Rows.Count
MATRIZ = .Rows(2).Resize(FILAS - 1)
ComboBox1.List = MATRIZ
.CurrentRegion.Clear
End With
End Sub
¡Gracias! mil James Bond, funciona perfecto y me soluciona un tema gigante
saludos...
Jorgef
Hola James Bond, se que debe tratarse de una bobada, en un libro nuevo el código funciona perfecto, pero al ajustarlo a lo que tengo no me llena los combobox podría compartirte el archivo o pegarte el código?
gracias
¿
¿Chequeaste qué en el libro nuevo existan las hojas producto y hoja 2?, ¿Qué el rango donde comienzan los datos sea A1?, la otra es que subas el archivo donde quieres usar la macro a un servicio de nube y pegar el link aquí para descargarlo.
Hola James Bond, te comparto el link de OneDrive donde cargue el archivo
https://1drv.ms/x/s!ArQzD0pBftLGiGHnPJl19UrhFWpn
Para entrar en contexto.
cuando abres el archivo, encuentras la hoja Formulario que contiene por ahora un botón que te abrirá un userform que simula usuario y contraseña, al dar click en ingresar, abre userform frmLogistica. en el combobox cmbTipoGestionLogistica el usuario marca la opción 1 y le habilita las dos primeras pestañas, en la pestaña 2 es donde tengo el problema. en el combobox cmbLineaNegocio2 van las líneas de negocio y en el combobox cmbGrupoInsumo2 van los grupos.
en la hoja Productos tengo el listado de productos y la tabla se llama Productos y adicioné la hoja ConsultaProductos (simulando tu hoja2) para la consulta y el llenado del listbox lbxProductos. pero al usar los combobox no me trae nada. se que debe ser alguna bobada, pero no la he podido cuadrar (no se si sea por mayúsculas/minúsculas)
nuevamente agradezco tu tiempo y paciencia
Saludos..
Jforero
Ya vi tu código y el error es este el initialze lo tienes mal nombrado el nombre correcto es el useform_initialize, en la imagen esta el resultado haciendo la corrección que mencione 
Y esta es la macro
Private Sub UserForm_Activate()
mlpPDM("pag1PDM").Enabled = False
mlpPDM("pag2PDMMateriales").Enabled = False
mlpPDM("pag3PDMHerramientas").Enabled = False
mlpPDM("pag4Despachos").Enabled = False
mlpPDM("pag5Ajustes").Enabled = False
End Sub
Private Sub cmbTipoGestionLogistica_Change()
'Trae Usuario y Fecha
txbNombreUsuarioPDM.Value = Worksheets("Calculo").Range("b1")
txbFechaPDM.Value = Format$(Date, "dd/mm/yyyy")
txbNombreUsuarioPDM.Enabled = False
txbFechaPDM.Enabled = False
'Inicia selección de la Gestión
If cmbTipoGestionLogistica.Value = "1-. Pedido Material" Then
'habilita la pestaña a trabajar
mlpPDM("pag1PDM").Enabled = True
mlpPDM("pag2PDMMateriales").Enabled = True
mlpPDM("pag3PDMHerramientas").Enabled = False
mlpPDM("pag4Despachos").Enabled = False
mlpPDM("pag5Ajustes").Enabled = False
End If
If cmbTipoGestionLogistica.Value = "3-. Herramientas" Then
'habilita la pestaña a trabajar
mlpPDM("pag3PDMHerramientas").Enabled = True
mlpPDM("pag1PDM").Enabled = False
mlpPDM("pag2PDMMateriales").Enabled = False
mlpPDM("pag4Despachos").Enabled = False
mlpPDM("pag5Ajustes").Enabled = False
End If
If cmbTipoGestionLogistica.Value = "4-. Despachos" Then
'habilita la pestaña a trabajar
mlpPDM("pag4Despachos").Enabled = True
mlpPDM("pag1PDM").Enabled = False
mlpPDM("pag2PDMMateriales").Enabled = False
mlpPDM("pag3PDMHerramientas").Enabled = False
mlpPDM("pag5Ajustes").Enabled = False
End If
If cmbTipoGestionLogistica.Value = "5-. Ajustes" Then
'habilita la pestaña a trabajar
mlpPDM("pag5Ajustes").Enabled = True
mlpPDM("pag1PDM").Enabled = False
mlpPDM("pag2PDMMateriales").Enabled = False
mlpPDM("pag3PDMHerramientas").Enabled = False
mlpPDM("pag4Despachos").Enabled = False
End If
End Sub
'Gestiona el pedido en los textbox, combobox y calendar
Private Sub btnCalFechaEntergaMaterial1_Click()
txbFechaEntrega1.Enabled = False
Call AbrirCalendariobtnCalFechaEntergaMaterial1
End Sub
Private Sub cmbCodigoProyectoPDM1_Change()
DatoBuscar = cmbCodigoProyectoPDM1.Value
Set buscar = Worksheets("Tablas").Range("l:m").Find(DatoBuscar, LookIn:=xlValues, LookAt:=xlWhole)
If Not buscar Is Nothing Then
txbNombrePRoyectoPDM1.Text = buscar.Offset(0, 1)
End If
txbNombrePRoyectoPDM1.Enabled = False
End Sub
Private Sub btnSalir_Click()
frmLogistica.Hide
End Sub
'Selecciona Línea de Negocio / Grupo de Insumos
Private Sub cmbLineaNegocio2_Change()
Dim FUNCION As WorksheetFunction
Dim UNICOS As New Collection
Set FUNCION = WorksheetFunction
Set PRODUCTOS = Range("TABLA_PRODUCTOS")
LINEA = cmbLineaNegocio2.Value
With PRODUCTOS
FILAS = .Rows.Count
columnas = .Columns.Count
cuenta = FUNCION.CountIf(.Columns(columnas - 1), LINEA)
INDICE = FUNCION.Match(LINEA, .Columns(columnas - 1), 0)
Set insumos = .Rows(INDICE).Resize(cuenta)
End With
cmbGrupoInsumo2.Clear
lbxProductos.RowSource = Empty
With insumos
FILAS = .Rows.Count
columnas = .Columns.Count
For I = 1 To FILAS
insumo = .Cells(I, columnas)
On Error Resume Next
UNICOS.Add insumo, CStr(insumo)
If Err.Number = 0 Then cmbGrupoInsumo2.AddItem insumo
On Error GoTo 0
Next I
.Name = "INSUMOS"
End With
Set FUNCION = Nothing: Set PRODUCTOS = Nothing
End Sub
Private Sub cmbGrupoInsumo2_Change()
Dim FUNCION As WorksheetFunction
Set FUNCION = WorksheetFunction
Set insumos = Range("INSUMOS")
insumo = cmbGrupoInsumo2.Value
If insumo = Empty Then GoTo sal
With insumos
FILAS = .Rows.Count
columnas = .Columns.Count
cuenta = FUNCION.CountIf(.Columns(columnas), insumo)
INDICE = FUNCION.Match(insumo, .Columns(columnas), 0)
Set TABLA = .Rows(INDICE).Resize(cuenta)
End With
With Sheets("ConsultaProductos")
.Cells.Clear
TABLA.Copy: .Range("A3").PasteSpecial xlPasteValues
Range("TABLA_PRODUCTOS").Rows(1).Copy: .Range("A2").PasteSpecial xlPasteValues
Set destino = .Range("a2").CurrentRegion
With destino
Set destino = .Rows(2).Resize(cuenta)
End With
With lbxProductos
.RowSource = "ConsultaProductos!" & destino.Address
.ColumnCount = columnas
.ColumnHeads = True
End With
End With
Set destino = Nothing: Set insumos = Nothing: Set FUNCION = Nothing
sal:
End Sub
Private Sub frmLogistica_Activate()
With frmLogistica
.Caption = "MODULO DE PRODUCTOS"
.Move 150, 10
End With
End Sub
Private Sub frmLogistica_Initialize()
End Sub
Sub LINEAS_UNICAS()
Set PRODUCTOS = Range("TABLA_PRODUCTOS")
With PRODUCTOS
FILAS = .Rows.Count
columnas = .Columns.Count
.Columns(columnas + 3).CurrentRegion.Clear
Set UNICOS = .Columns(columnas + 3).Resize(FILAS, 1)
.Columns(5).Copy
End With
With UNICOS
.PasteSpecial xlValues
.RemoveDuplicates Columns:=1
FILAS = .CurrentRegion.Rows.Count
MATRIZ = .Rows(2).Resize(FILAS - 1)
cmbLineaNegocio2.List = MATRIZ
.CurrentRegion.Clear
End With
End Sub
Private Sub UserForm_Initialize()
Set hp = Worksheets("productos")
Set PRODUCTOS = hp.Range("A1").CurrentRegion
With PRODUCTOS
.Sort KEY1:=hp.Range(.Columns(5).Address), ORDER1:=1, _
KEY2:=hp.Range(.Columns(6).Address), ORDER2:=1, _
Header:=xlYes
.Name = "TABLA_PRODUCTOS"
End With
LINEAS_UNICAS
Set PRODUCTOS = Nothing
End Sub
