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,
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,