On 1 Sep, 10:43, NPell wrote:
On 29 Aug, 18:03, "Bernie Deitrick" <deitbe @ consumer dot org wrote:





Try it this way:

Sub TryNow()
Dim myA As Variant
Dim myV As Variant

myA = Array("Criteria 1", "Criteria 2")

For Each myV In myA
Sheets("Data").Range("A:J").AutoFilter Field:=10, Criteria1:=myV
Intersect(Range("A1").CurrentRegion, Range("A2:I" & Rows.Count)) _
* *.SpecialCells(xlCellTypeVisible).Copy _
Sheets(myV).Cells(Rows.Count, "A").End(xlUp)(2)
Sheets("Data").Cells.AutoFilter
Next myV
End Sub

--
HTH,
Bernie
MS Excel MVP

"NPell" wrote in message

....

Whatrs wrong with this??

I either get an error saying no data, or can not be used with multiple
selection.

* *Sheets("Data").Select
* *Selection.AutoFilter Field:=10, Criteria1:="Criteria 1"
* *Range("A1").Offset(1, 0).Select
* *Range("A1:I1").Offset(1, 0).Select
* *Range(Selection, Selection.End(xlDown)).Select
* *Selection.SpecialCells(xlCellTypeConstants, xlNumbers +
xlTextValues).Select
* *On Error GoTo ErrorTrap1
* *Selection.Copy
* *lastrow = Sheets("Criteria 1").Cells(Rows.Count,
"A").End(xlUp).Row
* *Sheets("Criteria 1").Range("A" & lastrow + 1).PasteSpecial
ErrorTrap1:
* *Application.CutCopyMode = False
* *Range("A1").Select

* *Sheets("Data").Select
* *Selection.AutoFilter Field:=10, Criteria1:="Criteria 2"
* *Range("A1").Offset(1, 0).Select
* *Range("A1:I1").Offset(1, 0).Select
* *Range(Selection, Selection.End(xlDown)).Select
* *Selection.SpecialCells(xlCellTypeConstants, xlNumbers +
xlTextValues).Select
* *On Error GoTo ErrorTrap2
* *Selection.Copy
* *lastrow = Sheets("Criteria 2").Cells(Rows.Count,
"A").End(xlUp).Row
* *Sheets("Criteria 2").Range("A" & lastrow + 1).PasteSpecial
ErrorTrap2:
* *Application.CutCopyMode = False
* *Range("A1").Select

Any advice?- Hide quoted text -

- Show quoted text -

I got "Error - No Cells Were Found" on Criteria 1, as it is blank.- Hide quoted text -

- Show quoted text -

Added an "On Error Resume Next". All sorted.
Thanks very much Bernie mate.