Hola buenas,

Tengo la siguiente cuestión.

Necesito poder filtrar con código VBA, para sacar los resultados únicos en una lista, para en el futuro hacer una lista validada con ella.

Tengo la siguiente tabla con "Soporte" y "Espacio". En la celda E5 tengo una lista validada con mis soportes y me gustaría sacar en G5 una lista con los espacios dependiendo del soporte que elija en mi lista validada de E5.

Es similar, por poner un ejemplo, a utilizar la función filtrar, como muestro en el ejemplo de F5 pero necesito hacerlo únicamente en VBA.

En las capturas muestro como me gustaría que se viera utilizando la función filtrar, pero me gustaría realizarlo utilizando únicamente código VBA.

Me gustaría que saltara el código al utilizar el evento change en la celda E5 donde esta la lista validada.

Adjunto fichero por si les sirve de ayuda.

Mil gracias de antemano! Un saludo!

 

 

 

Libro.xlsx

Prueba y comenta

Private Sub Worksheet_Change(ByVal Target As Range): Application.ScreenUpdating = False
    If Target.Address = "$E$5" Then
        Hoja1.Range("G5:G" & Hoja1.Cells(Hoja1.Rows.Count, "G").End(xlUp).Row).ClearContents
        valorSeleccionado = Range("E5").Value
        With Hoja1.Range("B4").CurrentRegion
            .AutoFilter 1, valorSeleccionado
            On Error Resume Next
            .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Offset(0, 1).Copy Hoja1.Range("G5")
            On Error GoTo 0
            .AutoFilter
        End With
    End If
End Sub

 

Libro.xlsm

hace 21 horas, JSDJSD dijo:

Private Sub Worksheet_Change(ByVal Target As Range): Application.ScreenUpdating = False
    If Target.Address = "$E$5" Then
        Hoja1.Range("G5:G" & Hoja1.Cells(Hoja1.Rows.Count, "G").End(xlUp).Row).ClearContents
        valorSeleccionado = Range("E5").Value
        With Hoja1.Range("B4").CurrentRegion
            .AutoFilter 1, valorSeleccionado
            On Error Resume Next
            .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Offset(0, 1).Copy Hoja1.Range("G5")
            On Error GoTo 0
            .AutoFilter
        End With
    End If
End Sub

 

Libro.xlsm 24.01 kB · 1 descarga

Genial amigo, muchísimas gracias me has solucionado muchísimo. Otra pequeña duda, si quisiera añadir otro criterio para filtrar, seria añadiéndolo en esta línea verdad?

.AutoFilter 1, valorSeleccionado,,valorSeleccionado2

No exactamente, sube tu nueva consulta

hace 21 horas, JSDJSD dijo:

Private Sub Worksheet_Change(ByVal Target As Range): Application.ScreenUpdating = False
    If Target.Address = "$E$5" Then
        Hoja1.Range("G5:G" & Hoja1.Cells(Hoja1.Rows.Count, "G").End(xlUp).Row).ClearContents
        valorSeleccionado = Range("E5").Value
        With Hoja1.Range("B4").CurrentRegion
            .AutoFilter 1, valorSeleccionado
            On Error Resume Next
            .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Offset(0, 1).Copy Hoja1.Range("G5")
            On Error GoTo 0
            .AutoFilter
        End With
    End If
End Sub

 

Libro.xlsm 24.01 kB · 1 descarga

Tengo otra duda disculpa... al ir a aplicarlo a mi Excel con los datos reales me he dado cuenta que tengo bastantes columnas y que tanto la columna por la que quiero filtrar como la columna que quiero resultado no estan una al lado de la otra, por lo que al aplicar este código no me da el resultado que quiero... He intentado modificarlo para ver si encontraba la solución pero nada... te reenvío el archivo modificado...

Perdon, mil gracias y un saludo 😓

Libro.xlsm

Prueba y comenta, si te fija en la lista desplegable te la he dejado sin duplicados y dinámica pero claro mediante macros, ya que con formulas soy muy malo, a ver si hay alguien que pueda aportar formula para tal fin.

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    Dim uf As Long
    If Target.Address = "$H$5" Then
        uf = Hoja1.Cells(Hoja1.Rows.Count, "J").End(xlUp).Row
        If uf = 4 Then uf = 5
        Hoja1.Range("J5:J" & uf).ClearContents
        valorSeleccionado = Range("H5").Value
        With Hoja1.Range("B4").CurrentRegion
            .AutoFilter 2, valorSeleccionado
            On Error Resume Next
            .Offset(1, 0).Resize(.Rows.Count - 1) _
            .SpecialCells(xlCellTypeVisible).Columns(4).Copy Hoja1.Range("J5")
            On Error GoTo 0
            .AutoFilter
        End With
    End If
End Sub

 

Libro.xlsm

Este es el de la lista desplegable sin duplicados, lo tienes en el módulo 1

Sub CrearListaDesplegableSinDuplicados()
    Dim ws As Worksheet
    Dim rngDatos As Range
    Dim rngLista As Range
    Dim dict As Object
    Dim cel As Range
    
    Set ws = ThisWorkbook.Sheets("Hoja1")
    Set rngLista = ws.Range("H5")
    Set rngDatos = ws.Range("C5:C" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row)
    Set dict = CreateObject("Scripting.Dictionary")
    
    For Each cel In rngDatos
        If Not dict.Exists(cel.Value) Then
            dict.Add cel.Value, Nothing
        End If
    Next cel
    
    With rngLista.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=Join(dict.Keys, ",")
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
End Sub

 

En 10/1/2024 at 20:41 , JSDJSD dijo:

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    Dim uf As Long
    If Target.Address = "$H$5" Then
        uf = Hoja1.Cells(Hoja1.Rows.Count, "J").End(xlUp).Row
        If uf = 4 Then uf = 5
        Hoja1.Range("J5:J" & uf).ClearContents
        valorSeleccionado = Range("H5").Value
        With Hoja1.Range("B4").CurrentRegion
            .AutoFilter 2, valorSeleccionado
            On Error Resume Next
            .Offset(1, 0).Resize(.Rows.Count - 1) _
            .SpecialCells(xlCellTypeVisible).Columns(4).Copy Hoja1.Range("J5")
            On Error GoTo 0
            .AutoFilter
        End With
    End If
End Sub

 

Libro.xlsm 28.94 kB · 1 descarga

Mil gracias!! Me resolviste algo con lo que llevaba tiempo estancado!!

Un placer