Adding autofilter criteria one by one
I would like to add AutoFilter criteria to my excel spreadsheet in a separate subscription.
What I have at the moment looks a little something like this
.AutoFilter Field:=deviceTypeColumnId, Criteria1:=[dScenarioIndependent], Operator:=xlOr, _
Criteria2:=[dSmartphoneDeviceType]
What I would like to have is the first filter method Criteria1 and then in another Sub add Criteria2 to the existing AutoFilter. In my opinion, it should look something like this:
Sub firstSub
.AutoFilter Field:=deviceTypeColumnId, Criteria1:=[dScenarioIndependent]
end sub
Sub secondSub
.AutoFilter mode:=xlAddCriteria, Field:=deviceTypeColumnId, Criteria1:=[dSmartphoneDeviceType]
'I know that mode doesn't exist, but is there anything like that?
end sub
Do you know any way to achieve this?
source to share
No, I know the way to "add" to the filter that was previously applied.
I have prepared a workflow that will work for what you are trying to do. You just need to add scripts to the case statement, going down to the maximum number of filters you want to have.
EDIT: what does it do; copy the filtered column to a new worksheet and remove duplicates in that column. Then you are left with the values that were used to filter the column. Assign values to an array and then apply the number of elements of the array as a filter in the column, including including the new value you want to filter. EDIT 2: Added to a function to find the last row when the table is already filtered (we want the last row, not the last visible row).
Option Explicit
Sub add_filter()
Dim wb As Workbook, ws As Worksheet, new_ws As Worksheet
Dim arrCriteria() As Variant, strCriteria As String
Dim num_elements As Integer
Dim lrow As Long, new_lrow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("data")
Application.ScreenUpdating = False
lrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range("A1:A" & lrow).Copy 'Copy column which you intend to add a filter to
Sheets.Add().Name = "filter_data"
Set new_ws = wb.Sheets("filter_data")
With new_ws
.Range("A1").PasteSpecial xlPasteValues
.Range("$A$1:$A$" & Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates _
Columns:=1, Header:=xlYes 'Shows what has been added to filter
new_lrow = Cells(Rows.Count, 1).End(xlUp).Row
If new_lrow = 2 Then
strCriteria = .Range("A2").Value 'If only 1 element then assign to string
Else
arrCriteria = .Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'If more than 1 element make array
End If
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
If new_lrow = 2 Then
num_elements = 1
Else
num_elements = UBound(arrCriteria, 1) 'Establish number elements in array
End If
lrow = last_row
Select Case num_elements
Case 1
ws.Range("$A$1:$A$" & lrow).AutoFilter 1, _
Array(strCriteria, "New Filter Value"), Operator:=xlFilterValues
Case 2
ws.Range("$A$1:$A$" & lrow).AutoFilter 1, _
Array(arrCriteria(1, 1), arrCriteria(2, 1), _
"New Filter Value"), Operator:=xlFilterValues
Case 3
ws.Range("$A$1:$A$" & lrow).AutoFilter 1, _
Array(arrCriteria(1, 1), arrCriteria(2, 1), _
arrCriteria(3, 1), "New Filter Value"), Operator:=xlFilterValues
End Select
Application.ScreenUpdating = True
End Sub
Functions:
Function last_row() As Long
Dim rCol As Range
Dim lRow As Long
Set rCol = Intersect(ActiveSheet.UsedRange, Columns("A"))
lRow = rCol.Row + rCol.Rows.Count - 1
Do While Len(Range("A" & lRow).Value) = 0
lRow = lRow - 1
Loop
last_row = lRow
End Function
Hope it helps.
source to share