A slight rearrangement of your input area on Result! works with this code
Sub FilterChosen()
Dim DataRange As Range
Dim critRange As Range
Dim DestinationRange As Range
Set critRange = Sheet3.Range("A1:A2")
Set DestinationRange = Sheet3.Range("A6")
With Sheet2
With Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
Set DataRange = .Resize(.Rows.Count, 7)
End With
End With
DestinationRange.Resize(10000, 7).Clear
DataRange.AdvancedFilter action:=xlFilterCopy, criteriarange:=critRange, copytorange:=DestinationRange, unique:=False
End Sub
Bookmarks