VBA Excel custom text filter by more than two texts

Question

I have a long table and usually I want to filter the asset numbers (The first column and rows from row 4 to row 3080) by more than one value. The excel custom text filter can't filter by more than two texts. I wonder if it is possible to filter by more than two. I know it might be possible in VBA.

Example, filter the column A by "85254","8782A" and "GH0012"

Answer 1

You can achieve the same simply by using Advanced Filter option. It is smart enough to filter your data on multiple columns and more than two values.

You just need to create Filter Criteria section where the column names must be similar to the column names of your data range and this could be in the same sheet or another. In criteria range, you can specify any number of values and multiple columns.

I have illustrated this in below screenshot of my example. Click OK button on advanced filter dialog and your date would be filtered out.

Answer 2

Here's some code. Just enter the values to filter by in the ValuesToFilter variable, select a cell somewhere in the column to filter and run the code. It works in Tables and informal lists:

Sub FilterList()
Dim ValuesToFilter As String
Dim FilterValues() As String
Dim ColNumberInFilterRange As Long
Dim FilterRange As Excel.Range
Dim InTable As Boolean
Dim CollUniqueValues As Collection
Dim i As Long

ValuesToFilter = "85254,8782A,GH0012" 'comma-separated string
If ActiveSheet Is Nothing Then
    MsgBox "No active worksheet."
    Exit Sub
End If

With Selection
    If .Cells.Count = 1 And IsEmpty(ActiveCell) Then
        MsgBox "Please select a cell within one or more cells with data."
        Exit Sub
    End If
    If Union(ActiveCell.EntireColumn, .EntireColumn).Address <> ActiveCell.EntireColumn.Address Then
        MsgBox "Only select from one column"
        Exit Sub
    End If
    'Set the range to be filtered depending on whether it's a Table or not
   If Not ActiveCell.ListObject Is Nothing Then
        Set FilterRange = ActiveCell.ListObject.Range
        InTable = True
    Else
        Set FilterRange = ActiveCell.CurrentRegion
    End If
    If Union(Selection, FilterRange).Address <> FilterRange.Address Then
        MsgBox "Please make sure all cells are within the same table or contiguous area."
        Exit Sub
    End If
    'If not in a table and we're filtering a different area than currently filtered
   'then turn the existing AutoFilter off, so no error when the new area gets filtered.
   If Not InTable And ActiveSheet.AutoFilterMode Then
        If ActiveSheet.AutoFilter.Range.Address <> .CurrentRegion.Address Then
            ActiveSheet.AutoFilterMode = False
        End If
    End If

    FilterValues = Split(ValuesToFilter, ",")
    'Try to add every selected value to a collection - only unique values will succeed
   Set CollUniqueValues = New Collection
    For i = LBound(FilterValues) To UBound(FilterValues)
        On Error Resume Next
        CollUniqueValues.Add FilterValues(i)
        On Error GoTo 0
    Next i
    'Transfer the collection to an array for the AutoFilter function
   ReDim FilterValues(1 To CollUniqueValues.Count)
    For i = LBound(FilterValues) To UBound(FilterValues)
        FilterValues(i) = CollUniqueValues(i)
    Next i
    'Determine the index of the column to be filtered within the FilterRange
   ColNumberInFilterRange = (.Column - FilterRange.Columns(1).Column) + 1
    FilterRange.AutoFilter Field:=ColNumberInFilterRange, Criteria1:=FilterValues, Operator:=xlFilterValues
End With
End Sub

This code is modified from this post of mine, where you enter the values into a userform. If you do this a lot, you might want to download the sample workbook. My post before that is about filtering by all the selected values in a column.