Ejecutar macro desde lista desplegable
Necesito tomar los datos de un filtro avanzado y aser que aparezcan los resultados en una lista desplegable. La idea esta. En la hoja3 de mi planilla selecciono la celda b1 que contiene una lista con los nombres de distintos clientes. Por otro lado tengo habilitada una macro (llamada "extraer") que filtra las distintas propiedades de los cltes con sus datos catastrales de forma que solo me aparecen los del cliente seleccionado. El objetivo es que al seleccionar desde la lista desplegable de clientes (celda B1) se cargue otra lista desplegable (en celda B2) con los datos catastrales de las propiedades de ese cliente. Estuve mirando otros ejemplos en este mismo foro y los mas parecido que halle seria esto:
Desde la hoja
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$b$1" Then Call extraer
End Sub
Y desde el modulo
sub extraer()
1)filtrar las propiedades del cliente seleccionado
2) Añadir los datos estriados a la lista desplegable de propiedades de ese cliente
Range("G2").Select
Selection.ClearContents
Range("G5:Q25").Select
Selection.ClearContents
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("G2").Select
ActiveCell.FormulaR1C1 = "=+R[-1]C[-5]"
Range("G4:Q24").Select
Range("datos").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"Criteria"), CopyToRange:=Range("G4:Q15"), Unique:=False
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("B2").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$Q$5:$Q$25"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
end sub
Pero no me esta funcinando. Si me pueden dar una mano mil
Para hacer pruebas de la macro, tengo que verificar en dónde están los datos de tus rangos "datos" y "criteria"
Podrías enviarme tu archivo para revisarlo, me explicas con colores un ejemplo de lo que necesitas.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “Osvaldo Landez” y el título de esta pregunta.
Hola Dante, gracias por responder. Allí te mande el correo con la planilla para que la veas. Gracias
Te regreso el archivo con lo siguiente:
1. Una macro en los eventos de la hoja "Hoja3", para cada vez que selecciones la celda B1, se cargue en automático, todos los nombres que tienes en la hoja "Datos personales"
2. Cada que modifiques la celda B1, en automático se limpie la celda B2, se filtre la información del nombre que seleccionaste y se llene la lista de validación en la celda B2.
Estas son las macros, en los eventos de la hoja3
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$1" Then
[B2].ClearContents
Call extraer
End If
End Sub
'
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Por.Dante Amor
If Not Intersect(Target, Range("B1")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
On Error Resume Next
ActiveWorkbook.Names("nombres").Delete
On Error GoTo 0
u = Sheets("Datos personales").Range("A" & Rows.Count).End(xlUp).Row
ActiveWorkbook.Names.Add Name:="nombres", RefersTo:=Sheets("Datos personales").Range("A2:A" & u)
End If
End SubY esta en el módulo:
Sub extraer()
'Act.Por.Dante Amor
Range("G2").ClearContents
Range("G5:Q25").ClearContents
Range("G2").FormulaR1C1 = "=+R[-1]C[-5]"
Range("G4:Q24").Select
Range("datos").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("Criteria"), CopyToRange:=Range("G4:Q4"), Unique:=False
u = Range("Q" & Rows.Count).End(xlUp).Row
With Range("B2").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=$Q$5:$Q$" & u
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End SubSaludos.Dante Amor
Si es lo que necesitas.
