How to use auto filter in excel vba?

[backspace20]

I have a workbook with 5 different sheets called "crop1","crop2","crop3","crop4" and "pro". I have written a code to first ask me to choose the crop type(worksheet) and then filter the data based on a criteria which I have defined in cells A1 and A2 of pro worksheet (For example cells A1 contains "property"(It is a header of one of columns in crop1,2,3,4 spreadsheets) and cell A2 contains "=2 stories"). Then I want to copy this filtered data to the new worksheet called testsheet. I have written the following code but unfortunately I get application-defined object defined error (in advanced filter line of code). How can I fix it? Any solution?

Private Sub fill() 
    Dim wb As Workbook, sh As String, ws As Worksheet, startcell As Range
    Dim lastrow As Long, lastcolumn As Long
    'To choose spreadsheet
    sh = InputBox("crop type?")
    'Add a sheet at the end of spreadsheets and change It's name to testsheet
     Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(ActiveSheet.Name).Name = "testsheet"
    'Finding dynamic range & Activate the worksheet
    Worksheets(sh).Activate
    Set startcell = Range("A1")
    lastrow = Cells(Rows.Count, startcell.Column).End(xlUp).Row
    lastcolumn = Cells(startcell.Row, Columns.Count).End(xlToLeft).Column
    'Advanced filter
    Sheets("sh").Range(startcell, Cells(lastrow, lastcolumn)).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("pro").Range("A1:A2"), CopyToRange:=Sheets("testsheet").Range("A1", Cells(lastrow, lastcolumn)), unique:=False
    End Sub

I changed the advanced filter line to the following code :

Sheets(sh).Range(startcell, Cells(lastrow, lastcolumn)).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets(pro).Range("A1:A2"), CopyToRange:=Sheets(testsheet).Range(A1, Cells(lastrow, lastcolumn)), unique:=False

But I get another error : subscript out of range.


I tried the following code. It worked for couple of times but then it crashed again!

Set rng = Range(startcell, Cells(lastrow, lastcolumn))
    rng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("pro").Range("A1:A2"), copytorange:=Sheets("testsheet").Range("A1"), unique:=False

How can I fix it?
Cheers,

[mancubus]

welcome to the forum.

make sure workbook does not have a sheet named 'testsheet'. or add a line to delete existing, if any, 'testsheet'.

try this:

Sub vbax_54742_AdvanceFilter_CopyToAnotherSheet()

    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "testsheet"
    
    With Worksheets(InputBox("crop type?"))
        .AutoFilterMode = False
        .Cells(1).CurrentRegion.AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=Worksheets("pro").Range("A1:A2"), _
            CopyToRange:=Range("A1"), _
            Unique:=False
        .AutoFilterMode = False
    End With

End Sub

[snb]

Please post your workbook.

[backspace20]

Thanks Mancubus, The problem was 'testsheet'. I removed it and now the code works properly.
I also used your cell(1).currentregion to make my code shorter. one more quick question How can I define the criteria range by using input box in my original code?(like what I did for crop type).
cheers,

[mancubus]

i personally dont like make users input data via boxes.

you may try below. it can be rewritten in different ways.

Sub vbax_54742_AdvanceFilter_CopyToAnotherSheet()

    Dim CritRange As Range
    
    On Error Resume Next
    
    Set CritRange = Application.InputBox(Prompt:="Please select criteria sheet and range", Title:="Criteria Range", Type:=8)
    If CritRange Is Nothing Then
        MsgBox Prompt:="Please select criteria range. Quitting macro...", Buttons:=vbOKOnly, Title:="Range not selected!"
        Exit Sub
    End If

    Application.DisplayAlerts = False
    Worksheets("testsheet").Delete
    Application.DisplayAlerts = True
        
    On Error GoTo 0
        
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "testsheet"
     
    With Worksheets(InputBox("crop type?"))
        .AutoFilterMode = False
        .Cells(1).CurrentRegion.AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=Worksheets(CritRange.Parent.Name).Range(CritRange.Address), _
        CopyToRange:=Range("A1"), _
        Unique:=False
        .AutoFilterMode = False
    End With
     
End Sub

[snb]

I'd prefer:

Sub M_snb()
    If [not(isref(testsheet!a1))] Then Sheets.Add.Name = "testsheet"
     
    Sheets(InputBox(Replace(" 1 2 3 4", " ", vbLf & "crop"))).Cells(1).CurrentRegion.AdvancedFilter 2, Sheets("pro").Cells(1).CurrentRegion, Sheets("testsheet").Cells(1)
End Sub

[backspace20]

i personally dont like make users input data via boxes.

you may try below. it can be rewritten in different ways.

Sub vbax_54742_AdvanceFilter_CopyToAnotherSheet()

    Dim CritRange As Range
    
    On Error Resume Next
    
    Set CritRange = Application.InputBox(Prompt:="Please select criteria sheet and range", Title:="Criteria Range", Type:=8)
    If CritRange Is Nothing Then
        MsgBox Prompt:="Please select criteria range. Quitting macro...", Buttons:=vbOKOnly, Title:="Range not selected!"
        Exit Sub
    End If

    Application.DisplayAlerts = False
    Worksheets("testsheet").Delete
    Application.DisplayAlerts = True
        
    On Error GoTo 0
        
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "testsheet"
     
    With Worksheets(InputBox("crop type?"))
        .AutoFilterMode = False
        .Cells(1).CurrentRegion.AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=Worksheets(CritRange.Parent.Name).Range(CritRange.Address), _
        CopyToRange:=Range("A1"), _
        Unique:=False
        .AutoFilterMode = False
    End With
     
End Sub

Many thanks for your help.

[mancubus]

you are welcome. please mark the thread as solved.

@snb
in case there are less filtered rows, a small modification in code to clear existing data in testsheet may be needed.

like

Sub M_snb()
    If [Not(IsRef(testsheet!A1))] Then Sheets.Add.Name = "testsheet" Else Sheets("testsheet").Cells.ClearContents
    Sheets(InputBox(Replace(" 1 2 3 4", " ", vbLf & "crop"))).Cells(1).CurrentRegion.AdvancedFilter 2, Sheets("pro").Cells(1).CurrentRegion, Sheets("testsheet").Cells(1)
End Sub

[snb]

@Backspace

Please, do not quote !


@MC
Then I'd prefer:

Sub M_snb() 
    If [Not(IsRef(testsheet!A1))] Then Sheets.Add.Name = "testsheet" 
    Sheets("testsheet").Cells.ClearContents 
    Sheets(InputBox(Replace(" 1 2 3 4", " ", vbLf & "crop"))).Cells(1).CurrentRegion.AdvancedFilter 2, Sheets("pro").Cells(1).CurrentRegion, Sheets("testsheet").Cells(1) 
End Sub