Give this a try, notice the new layout on the Filter Sheet. You can add and subtract to the rows of each column as you will and it will affect the results each time the macro is run. The macro will create a "Result" sheet as needed, your original data will remain for other filtering attempts.
Option Explicit
Sub FilterData()
'Jerry Beaucaire 5/8/2010
'https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/files
'Use a sheet of filter criteria to pare down a larger data set
Dim LastRow As Long, shtOut As Worksheet
Dim shtDt As Worksheet, shtFltr As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set shtDt = Sheets("QuerySheet")
LastRow = shtDt.Range("B" & shtDt.Rows.Count).End(xlUp).Row
If Not Evaluate("ISREF(Result!A1)") Then 'create new sheet if needed
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Result"
Else
Sheets("Result").Cells.Clear
End If
Set shtOut = Sheets("Result")
With shtDt
.Range("BB8") = "Key"
With .Range("BB9:BB" & LastRow) 'create filter key formula in empty column
.FormulaR1C1 = _
"=AND(ISNUMBER(MATCH(TRIM(RC6),Filters!C1,0)), ISNUMBER(MATCH(TRIM(RC3),Filters!C2,0)), OR(RC16="""",ISNUMBER(MATCH(TRIM(RC16),Filters!C3,0))), ISNUMBER(MATCH(TRIM(RC18),Filters!C4,0)))"
.Calculate
.Value = .Value
End With
.Range("BB8:BB" & LastRow).AutoFilter Field:=1, Criteria1:="TRUE"
LastRow = .Range("BB" & .Rows.Count).End(xlUp).Row
If LastRow > 8 Then 'copy filtered data to new sheet
.Range("B8:F" & LastRow & _
",M8:M" & LastRow & _
",P8:S" & LastRow & _
",W8:W" & LastRow).Copy shtOut.Range("A1")
End If
.AutoFilterMode = False
.Range("BB:BB").ClearContents
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
shtOut.Activate
End Sub
Bookmarks