For example I have a range which has cells containing A, B, C , D, E. I have a cell which has B,D. I want to filter out all the cells in the range which contains B,D and B and D.
For example I have a range which has cells containing A, B, C , D, E. I have a cell which has B,D. I want to filter out all the cells in the range which contains B,D and B and D.
ListObject) AutoFilter: Multiple Criteria With WildcardsAutoFilter.A Quick Fix
Sub MaterialWiseFix()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim tbl As ListObject: Set tbl = ws.ListObjects("Clients")
Dim cCell As Range: Set cCell = ws.Range("D4")
Dim cArr() As String: cArr = Split(CStr(cCell.Value), ",")
With tbl
If .ShowAutoFilter Then
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
End If
With .Range
Select Case UBound(cArr)
Case Is < LBound(cArr)
MsgBox "No criteria.", vbCritical
Case 0
.AutoFilter 9, "*" & cArr(0) & "*"
Case Else
.AutoFilter 9, "*" & cArr(0) & "*", xlOr, "*" & cArr(1) & "*"
If UBound(cArr) > 1 Then
MsgBox "Only filtered by the first two criteria. " _
& "There are more.", vbExclamation
End If
End Select
End With
End With
End Sub
Sub MaterialWise()
' Define constants.
Const TableName As String = "Clients"
Const CriteriaCellAddress As String = "D4"
Const Delimiter As String = ","
Const CriteriaColumn As Long = 9
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Reference the table ('tbl').
Dim tbl As ListObject: Set tbl = ws.ListObjects(TableName)
' Reference the Criteria cell ('cCell').
Dim cCell As Range: Set cCell = ws.Range(CriteriaCellAddress)
' Using the Split function, write the criteria strings
' to the Criteria array ('cArr'), a 1D zero-based array.
Dim cArr() As String: cArr = Split(CStr(cCell.Value), Delimiter)
' Clear table filters.
With tbl
If .ShowAutoFilter Then
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
End If
End With
Dim FoundMore As Boolean
' Handle up to two criteria...
With tbl.Range
Select Case UBound(cArr)
Case Is < LBound(cArr) ' blanks
.AutoFilter CriteriaColumn, ""
Case 0 ' 1 criterion
.AutoFilter CriteriaColumn, "*" & cArr(0) & "*"
Case 1 ' 2 criteria
.AutoFilter CriteriaColumn, _
"*" & cArr(0) & "*", xlOr, "*" & cArr(1) & "*"
Case Else
FoundMore = True
End Select
End With
If Not FoundMore Then Exit Sub
' Handle more than two criteria...
' Write the values from the column to the Data array ('Data'),
' a 2D one-based one-column array.
Dim Data() As Variant
With tbl.DataBodyRange.Columns(CriteriaColumn)
If .Rows.Count = 1 Then ' one cell
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
Else ' multiple cells
Data = .Value
End If
End With
' Create and reference a new dictionary object ('dict').
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case-insensitive
' Write the Criteria array's upper limit to a variable ('cUpper')
' since it's going to be used in a loop.
Dim cUpper As Long: cUpper = UBound(cArr)
' Declare additional variables.
Dim r As Long ' Data Array Row Counter
Dim c As Long ' Criteria Array Elements Counter
Dim cString As String ' Current String in Data Array
' Write the unique strings in the Data array, meeting any of the criteria,
' to the 'keys' of the dictionary.
For r = 1 To UBound(Data, 1)
cString = CStr(Data(r, 1))
For c = 0 To cUpper
If InStr(1, cString, cArr(c), vbTextCompare) > 0 Then Exit For
Next c
If c <= cUpper Then dict(cString) = Empty
Next r
' Filter the table by the 'keys' of the dictionary.
tbl.Range.AutoFilter CriteriaColumn, dict.Keys, xlFilterValues
End Sub