Is there a macro to filter table by some list elements?

Question

I have a table with entries based on a list and I used a macro I found somewhere to be able to add/remove multiple elements from the list to one cell, let me show you an example:

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

Where items from the list are test1, test2, and so on.

Now I don't know if this is even possible, but I would like to be able to instantly filter the table by specific item from the list (for example test1), moreover I would like to put these criteria in a chceckbox filters so that instead of checkboxes like "test1, test2" in the checkboxes I would have only single items from the list (like test1, test2 and so on)

Is it even possible, and if yes can someone help to prepare a macro for this? In addition I am putting here my macro from the workbook:

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

Answer 1

Even though this is an old post, I'm providing one way of doing it, as a reference

• Create a new UserForm with default name "UserForm1"
• Create a new ComboBox with default name "ComboBox1" on the form, similar to this

---

Add this code to the VBA module for the Form:

---

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

---

Paste this code in the VBA module for 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

Sheet1 data:

---

Paste this code into a standard VBA module (open VBA: Alt + F11, click menu Insert > Module)

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

---

Clicking on the header column ("TEST TABLE") will filter the list in 2 parts

Part 1:

• Extract the items from all cells of the current column into the first unused column of the sheet
• Trim all items, using Excel TRIM() formula (not copy-past using the clipboard)
• Remove duplicates from the list: .RemoveDuplicates Columns:=1, Header:=xlNo
• Sort the items in place (words in each cell are not separated yet)
• Create one string containing all text, separated by commas

Part 2:

• Split the string again
• Trim all items (cell words are now separated an can contain extra spaces)
• Remove duplicates from the list and sort them once more
• Create one final string containing the filtered list
• Update the combo box drop-down with final items

When the user selects an item from the drop-down list

• It will perform an Autofilter for cells containing partial text

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

• Button Clear Sort removes the Autofilter

• Button Cancel closes the form, without removing the filter

• Once the form is closed, the filter can be removed 3 ways

  • The standard way, using the Autofilter drop-down, and "Select All"
  • Menu Data Tab and clicking the Filter button
  • Clicking on the column header again (TEST TABLE)

---

Filtered drop-down list:

Filtered rows using criteria "test3"

Clear previous filter: