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
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
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
- Compartir respuesta