使用多个条件将行从一张纸复制到另一张纸上

我正在处理一个macros，它将search不同县的列表表单，然后将整行粘贴到当前表单上。 我有一个每个人（名为马克，约翰等）的工作表，每个人被分配到几个县。 马克有三个县，列在单元格J1：L1，我已经命名为范围（MyCounties）。 我需要一个macros查看每个县的表“列表”列“I”，并将整行复制到“A4”开始的表“标记”。 我正在使用我在这里find的一个修改后的macros，但是我一定是做错了什么。 它目前给我一个关于Set Rng = Sheets("List").Range([I4], Range("I" & Rows.Count).End(xlUp))的错误“Application defined or object defined error” 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

此代码将需要调整以适应您的命名范围和工作表名称。 它目前在每个工作表中使用具有工作表范围的命名范围。

 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 

这将使用每个工作表的MyCounties命名范围中的值作为.AutoFilter的一组条件。 使用数组作为条件需要Operator:=xlFilterValues参数。 它还检查以确保在复制之前有过滤的值要复制。

Answer 2

可能是您的EntireRow正在复制第一EntireRow空的行

您可以使用工作表对象的UsedRange属性来获取上次使用的行

此外你最好放置With Rng oustide循环，因为它不会改变

 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