I am using a custom Autofilter by use of a dictionary as in the below code.
Now, I need to set an additional autofilter on the already filtered column.
e.g. the result of the first autofilter is ("ID 20 , Name30 , Color 35 , ID39"),
on the second autofilter, I need to filter for a string contains e.g. "*30*".
I need to do it in a second separate step, I mean, after placing the first filter in the way I tried and then I closed that workbook completely (to be eloquent), I need then to apply the second filter on the already filtered range, by cells containing 30. or meaning apply filter on the data found on the visible cells only.
Note, I do not prefer to use a a helper column/sheet ,
and also want to keep my code as it is, meaning I seek for additional sub.
In advance, great thanks for your time of help.
Option Explicit
Option Compare Text
Sub Filter_the_Filtered_Column()
Const filter_Column As Long = 2
Dim filter_Criteria() As Variant
filter_Criteria = Array("*Id*", "*Name*", "*Color*")
Dim ws As Worksheet: Set ws = ActiveSheet
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim rg As Range
Set rg = ws.UsedRange.Resize(ws.UsedRange.Rows.count - 1).Offset(1) '(UsedRange except the first Row)
Dim rCount As Long, arr() As Variant, dict As Object, el, r As Long
rCount = rg.Rows.count - 1
arr = rg.Columns(filter_Column).Resize(rCount).Offset(1).value 'Write the values from criteria column to an array.
Set dict = CreateObject("Scripting.Dictionary") 'Write the matching strings to the keys (a 1D array) of a dictionary.
For r = 1 To UBound(arr) 'Loop through the elements of the array.
For Each el In filter_Criteria
If arr(r, 1) Like el Then dict(arr(r, 1)) = vbNullString: Exit For
Next el
Next r
If dict.count > 0 Then
rg.AutoFilter Field:=filter_Column, Criteria1:=dict.Keys, Operator:=xlFilterValues 'use the keys of the dictionary (a 1D array) as a Criteria
End If
End Sub
If you do want it as a separated sub, you can try this:
Sub filteredRangeToArray()
Const filter_Column As Long = 2
Dim ws As Worksheet, arr(), rng As Range, newSh As Worksheet
Dim lRow As Long, r As Long
Dim nFilter As String: nFilter = "30"
Dim dict As Object
Set ws = ActiveWorkbook.ActiveSheet
lRow = ws.Range("A" & Rows.Count).End(xlUp).Row
Set rng = ws.Range("A2:A" & lRow).SpecialCells(xlCellTypeVisible)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set newSh = Worksheets.Add
rng.Copy newSh.Range("A1")
arr = newSh.Range("A1:A" & rng.Count).Value
newSh.Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set dict = CreateObject("Scripting.Dictionary")
For r = 1 To UBound(arr, 1)
If arr(r, 1) Like nFilter Then dict(arr(r, 1)) = vbNullString
Next r
If dict.Count > 0 Then
rg.AutoFilter Field:=filter_Column, Criteria1:=dict.Keys, Operator:=xlFilterValues 'use the keys of the dictionary (a 1D array) as a Criteria
End If
End Sub
But now that I see FaneDuru's comment about making the dict a global variable, it could be a lot faster/easier of course. I'll leave my answer for when you don't want to use that.
Edit:
Sub filteredRangeToArray_V2()
Const filter_Column As Long = 2
Dim ws As Worksheet, arr(), rng As Range, newSh As Worksheet
Dim lRow As Long, r As Long
Dim nFilter As String: nFilter = "*30*"
Dim dict As Object
Dim ccell As Range
Set ws = ActiveWorkbook.ActiveSheet
lRow = ws.Range("A" & Rows.Count).End(xlUp).Row
Set rng = ws.Range("A2:A" & lRow).Offset(0, filter_Column - 1).SpecialCells(xlCellTypeVisible)
ReDim arr(1 To rng.Count)
r = 1
For Each ccell In rng.Cells
arr(r) = ccell.Value
r = r + 1
Next ccell
Set dict = CreateObject("Scripting.Dictionary")
For r = 1 To UBound(arr, 1)
If arr(r) Like nFilter Then dict(arr(r)) = vbNullString
Next r
Set rng = ws.UsedRange.Resize(ws.UsedRange.Rows.Count)
rng.Select
If ws.AutoFilterMode Then ws.AutoFilterMode = False
If dict.Count > 0 Then
rng.AutoFilter Field:=filter_Column, Criteria1:=dict.Keys, Operator:=xlFilterValues 'use the keys of the dictionary (a 1D array) as a Criteria
End If
End Sub
This should accommodate the not needing another sheet/helper-column.