¿Hay una macro para filtrar la tabla por algunos elementos de la lista?

Tengo una tabla con entradas basadas en una lista y usé una macro que encontré en algún lugar para poder agregar / eliminar múltiples elementos de la lista a una celda, déjame mostrarte un ejemplo:

TEST TABLE
test1
test1, test2
test1, test3
test2, test3, test4

Donde los elementos de la lista son test1, test2, etc.

Ahora no sé si esto es posible, pero me gustaría poder filtrar instantáneamente la tabla por elemento específico de la lista (por ejemplo, prueba 1), además me gustaría poner estos criterios en los filtros de un cuadro de verificación para que En lugar de las casillas de verificación como "test1, test2" en las casillas de verificación, solo tendría elementos únicos de la lista (como test1, test2, etc.)

¿Es incluso posible, y si es así, alguien puede ayudar a preparar una macro para esto? Además estoy poniendo aquí mi macro del libro de trabajo:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then
   'do nothing
Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
    If oldVal = "" Then
      'do nothing
      Else
      If newVal = "" Then
      'do nothing
      Else
        lUsed = InStr(1, oldVal, newVal)
        If lUsed > 0 Then
            If Right(oldVal, Len(newVal)) = newVal Then
                Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
            Else
                Target.Value = Replace(oldVal, newVal & ", ", "")
            End If
        Else
            Target.Value = oldVal _
              & ", " & newVal
        End If

      End If
  End If
End If

exitHandler:
  Application.EnableEvents = True

Call AutoFitColumns

End Sub

Sub AutoFitColumns()
Dim rng As Range
Set rng = Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft))
rng.EntireColumn.AutoFit
End Sub

A pesar de que este es un post antiguo, estoy proporcionando una forma de hacerlo, como referencia

• Cree un nuevo UserForm con el nombre predeterminado "UserForm1"
• Cree un nuevo ComboBox con el nombre predeterminado "ComboBox1" en el formulario, similar a este

Agregue este código al módulo VBA para el formulario:

Option Explicit

Private enableEvts As Boolean
Private thisCol As Range

Private Sub ComboBox1_Change()
   If enableEvts Then filterColumn thisCol, ComboBox1.Text
   'Me.Hide
End Sub

Public Sub setupList(ByRef col As Range)
   Set thisCol = col
   enableEvts = False
      setList col, ComboBox1
   enableEvts = True
   Me.Caption = "Filter Column: " & Left(col.Address(, False), 1)
End Sub

Private Sub ComboBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
   If KeyAscii = vbKeyEscape Then Me.Hide
End Sub
Private Sub CommandButton1_Click()
   ComboBox1.ListIndex = -1
   If Not Sheet1.AutoFilter Is Nothing Then Sheet1.UsedRange.AutoFilter
End Sub
Private Sub CommandButton2_Click()
   Me.Hide
End Sub
Private Sub UserForm_Click()
   Me.Hide
End Sub

Pegue este código en el módulo VBA para Sheet1:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   With Target
      If .CountLarge = 1 Then
         removeAllFilters Me
         If .Row = 1 Then
            .Offset(1, 0).Activate
            UserForm1.setupList Me.UsedRange.Columns(.Column)
            UserForm1.Show
         End If
      End If
   End With
End Sub

Hoja de datos 1:

Pegue este código en un módulo VBA estándar (abra VBA: Alt + F11 , haga clic en el menú Insertar & gt; Módulo)

Option Explicit

Public Sub setList(ByRef rng As Range, ByRef cmb As ComboBox)
   Dim ws As Worksheet, lst As Range, lr As Long

   If rng.Columns.Count = 1 Then
      xlEnabled False
      Set ws = rng.Parent
      removeAllFilters ws
      Set lst = ws.UsedRange.Columns(rng.Column)
      lr = getLastRow(lst, rng.Column)

      If lr > 1 Then
         With cmb
            .List = Split(getDistinct(lst, lr), ",")
            .ListIndex = -1
         End With
      End If
      xlEnabled True
   End If
End Sub

Public Sub xlEnabled(ByVal onOff As Boolean)
    Application.ScreenUpdating = onOff
    Application.EnableEvents = onOff
End Sub

Private Function getLastRow(ByRef rng As Range, ByVal lc As Long) As Long
   Dim ws As Worksheet, lr As Long
   If Not rng Is Nothing Then
      Set ws = rng.Parent
      lr = ws.Cells(rng.Row + ws.UsedRange.Rows.Count + 1, lc).End(xlUp).Row
      Set rng = ws.Range(ws.Cells(1, lc), ws.Cells(lr, lc)) 'updates rng (ByRef)
   End If
   getLastRow = lr
End Function

Private Function getDistinct(ByRef rng As Range, ByVal lr As Long) As String
   Dim ws As Worksheet, lst As String, lc As Long, tmp As Range, v As Variant, c As Double

   Set ws = rng.Parent
   lc = ws.Cells(rng.Row, rng.Column + ws.UsedRange.Columns.Count + 1).End(xlToLeft).Column
   Set tmp = ws.Range(ws.Cells(1, lc + 1), ws.Cells(lr, lc + 1))

   If tmp.Count > 1 Then
      With tmp.Cells(1, 1)
         .Formula = "=Trim(" & ws.Cells(rng.Row, lc).Address(False, False) & ")"
         .AutoFill Destination:=tmp
      End With

      tmp.Value2 = tmp.Value2       'convert formulas to values
      tmp.Cells(1, 1).ClearContents 'remove header from list
      cleanCol tmp, lc
      lr = getLastRow(tmp, lc + 1)

      lst = Join(Application.Transpose(tmp), ",")
      lst = Replace(lst, ", ", ","):   lst = Replace(lst, " ,", ",")
      v = Application.Transpose(Split(lst, ","))

      lr = UBound(v)
      ws.Range(ws.Cells(1, lc + 1), ws.Cells(lr, lc + 1)) = v
      getLastRow tmp, lc + 1

      cleanCol tmp, lc
      getLastRow tmp, lc + 1
      lst = Join(Application.Transpose(tmp), ",")
      lst = Replace(lst, ", ", ","):   lst = Replace(lst, " ,", ",")
      tmp.Cells(1, 1).EntireColumn.Clear
   End If
   getDistinct = lst
End Function

Public Sub filterColumn(ByRef col As Range, ByVal fltrCriteria As String)
   Dim ws As Worksheet, lst As Range, lr As Long

   xlEnabled False
   Set ws = col.Parent
   Set lst = ws.UsedRange.Columns(col.Column)
   lr = getLastRow(lst, col.Column)

   lst.AutoFilter
   lst.AutoFilter Field:=1, Criteria1:="*" & fltrCriteria & "*"
   xlEnabled True
End Sub

Private Sub cleanCol(ByRef tmp As Range, ByVal lc As Long)
   Dim ws As Worksheet, lr As Long

   Set ws = tmp.Parent
   tmp.RemoveDuplicates Columns:=1, Header:=xlNo
   lr = getLastRow(tmp, lc + 1)

   ws.Sort.SortFields.Add Key:=ws.Cells(lr + 1, lc + 1), Order:=xlAscending
   With ws.Sort
      .SetRange tmp
      .Header = xlNo
      .MatchCase = False
      .Orientation = xlTopToBottom
      .Apply
   End With
End Sub

Public Sub removeAllFilters(ByRef ws As Worksheet)

   If Not ws.AutoFilter Is Nothing Then ws.UsedRange.AutoFilter
   ws.Rows.Hidden = False

End Sub

Al hacer clic en la columna del encabezado ("TEST TABLE") se filtrará la lista en 2 partes

Parte 1:

• Extraiga los elementos de todas las celdas de la columna actual en la primera columna no utilizada de la hoja
• Recorte todos los elementos, utilizando la fórmula de Excel TRIM () (no copie y pegue utilizando el portapapeles)
• Eliminar duplicados de la lista: .RemoveDuplicates Columns:=1, Header:=xlNo
• Ordenar los elementos en su lugar (las palabras en cada celda aún no están separadas)
• Crea una cadena que contenga todo el texto, separados por comas.

Parte 2:

• Dividir la cadena de nuevo
• Recorte todos los elementos (las palabras de celda ahora están separadas y puede contener espacios adicionales)
• Eliminar duplicados de la lista y ordenarlos una vez más
• Crear una cadena final que contenga la lista filtrada
• Actualice el cuadro desplegable combinado con los elementos finales.

Cuando el usuario selecciona un elemento de la lista desplegable

• Realizará un Autofiltro para celdas que contengan texto parcial.

  • Criteria1:="*" & fltrCriteria & "*", (Ex "* test3 *" )

• Botón Borrar orden elimina el Autofiltro

• Botón Cancelar Cierra el formulario, sin quitar el filtro.

• Una vez que se cierra el formulario, el filtro se puede quitar de 3 maneras

  • La forma estándar, utilizando el menú desplegable Autofiltro y "Seleccionar todo"
  • Menú Pestaña de datos y haciendo clic en el Filtrar botón
  • Haciendo clic nuevamente en el encabezado de la columna (TABLE TABLE)

Lista desplegable filtrada:

Filas filtradas utilizando los criterios "test3"

Borrar filtro anterior: