CODEWITHSUNDEEP
vbaexcel
user4907546
user4907546

Reputation: 121

copy rows from one sheet to another with multiple criteria

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

Upvotes: 0

Views: 191

Answers (2)

user4039065
user4039065

Reputation:

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.

Upvotes: 1

user3598756
user3598756

Reputation: 29421

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

Upvotes: 0

Related Questions