PDA

View Full Version : [SOLVED] How to use auto filter in excel vba?



backspace20
01-06-2016, 11:08 PM
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
01-07-2016, 12:42 AM
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
01-07-2016, 02:05 AM
Please post your workbook.

backspace20
01-07-2016, 04:00 AM
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
01-07-2016, 07:06 AM
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
01-07-2016, 09:08 AM
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
01-08-2016, 05:42 AM
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
01-08-2016, 06:48 AM
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
01-08-2016, 06:57 AM
@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