copy rows from one sheet to another with multiple criteria - vba

Question

I'm working on a macro that will search a List sheet for different counties and then paste the entire row onto the current sheet. I have a worksheet for each person (named Mark, John, etc.) and each person is assigned several counties. Mark has three counties, listed in cells J1:L1, which I've named as a range (MyCounties). I need a macro that will look through Sheet "List" column "I" for each of those counties and copy the entire row onto Sheet "Mark" starting at "A4". I'm using a modified macro I found on here, but I must be doing something wrong. It is currently giving me an error "Application defined or object defined error" in regards to Set Rng = Sheets("List").Range([I4], Range("I" & Rows.Count).End(xlUp))
Sub NewSheetData()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim Rng As Range, rCell As Range
Set Rng = Sheets("List").Range([I4], Range("I" & Rows.Count).End(xlUp))
For Each rCell In Range("MyCounties")
On Error Resume Next
With Rng
.AutoFilter , field:=1, Criteria1:=rCell.Value
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
.AutoFilter
End With
On Error GoTo 0
Next rCell
Application.EnableEvents = True
End Sub

Answer 1

This code will need to be adjusted to accommodate your named ranges and worksheet names. It currently uses named ranges with worksheet scope from each worksheet.
Sub NewSheetData()
Dim w As Long, sWSs As Variant, vCrit As Variant, rw As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
sWSs = Array("Mark", "John", "etc")
For w = LBound(sWSs) To UBound(sWSs)
With Worksheets(sWSs(w))
vCrit = .Range("MyCounties").Value2
rw = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 4)
End With
With Worksheets("List")
If .AutoFilterMode Then .AutoFilterMode = False
With .Range(.Cells(4, "I"), .Cells(.Rows.Count, "I").End(xlUp))
.AutoFilter field:=1, Criteria1:=vCrit, Operator:=xlFilterValues
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
If CBool(Application.Subtotal(103, .Cells)) Then
.Cells.EntireRow.Copy Destination:=Worksheets(sWSs(w)).Cells(rw, "A")
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
Next w
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
This uses the values from each worksheet's MyCounties named range as an array of criteria for .AutoFilter. using an array as criteria requires the Operator:=xlFilterValues parameter. It also checks to make sure that there are filtered values to copy before copying them.

Answer 2

may be your EntireRow is copying rows whose first column is blank
you could use UsedRange property of worksheet object to get the last used row
furthermore you'd better place With Rng oustide the loop, since it doesn't change with it
Option Explicit
Sub NewSheetData()
Dim Rng As Range, rCell As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With Sheets("List")
Set Rng = .Range("I4", .Range("I" & .Rows.Count).End(xlUp))
End With
With Rng
For Each rCell In Range("MyCounties")
.AutoFilter , Field:=1, Criteria1:=rCell.Value
If Application.WorksheetFunction.Subtotal(103, .cells) > 1 Then .Resize(.Rows.Count - 1).Offset(1).EntireRow.Copy _
Sheets("Sheeta2").Range("A" & Sheets("Sheeta2").UsedRange.Rows(Sheets("Sheeta2").UsedRange.Rows.Count).Row).Offset(1)
Next
.Parent.AutoFilterMode = False
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub