将基于多个条件的行从一个工作表复制到另一个VBA

我正在尝试将库存表中的行复制到水果工作表，但是下面的代码会将副本粘贴到同一工作表中。 我不知道如何改变这一点。 有人能帮助我吗？ 提前感谢任何帮助！

Sub FruitBasket() Dim rngCell As Range Dim lngLstRow As Long Dim strFruit() As String Dim intFruitMax As Integer intFruitMax = 3 ReDim strFruit(1 To intFruitMax) strFruit(1) = "Fruit 2" strFruit(2) = "Fruit 5" strFruit(3) = "Fruit 18" lngLstRow = ActiveSheet.UsedRange.Rows.Count For Each rngCell In Range("A2:A" & lngLstRow) For i = 1 To intFruitMax If strFruit(i) = rngCell.Value Then rngCell.EntireRow.Copy Sheets("Inventory").Select Range("A65536").End(xlUp).Offset(1, 0).Select Selection.PasteSpecial xlPasteValues Sheets("Fruit").Select End If Next i Next End Sub 

Answer 1

替代方法使用自动filter避免有一个循环。 评论清晰：

 Sub tgr() Dim wsData As Worksheet Dim wsDest As Worksheet Dim aFruit() As String Set wsData = Sheets("Inventory") 'Copying FROM this worksheet (it contains your data) Set wsDest = Sheets("Fruit") 'Copying TO this worksheet (it is your destination) 'Populate your array of values to filter for ReDim aFruit(1 To 3) aFruit(1) = "Fruit 2" aFruit(2) = "Fruit 5" aFruit(3) = "Fruit 18" With wsData.Range("A1", wsData.Cells(wsData.Rows.Count, "A").End(xlUp)) .AutoFilter 1, aFruit, xlFilterValues 'Filter using the array, this avoids having to do a loop 'Copy the filtered data (except the header row) and paste it as values .Offset(1).EntireRow.Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues Application.CutCopyMode = False 'Remove the CutCopy border .AutoFilter 'Remove the filter End With End Sub 

Answer 2

尝试这个：

 Sub FruitBasket() Dim rngCell As Range Dim lngLstRow As Long Dim strFruit() As String Dim intFruitMax As Integer Dim tWs As Worksheet intFruitMax = 3 ReDim strFruit(1 To intFruitMax) Set tWs = Sheets("Inventory") strFruit(1) = "Fruit 2" strFruit(2) = "Fruit 5" strFruit(3) = "Fruit 18" With Sheets("Fruit") lngLstRow = .Range("A" & .Rows.Count).End(xlUp) For Each rngCell In .Range("A2:A" & lngLstRow) For i = 1 To intFruitMax If strFruit(i) = rngCell.Value Then tWs.Rows(tWs.Range("A" & tWs.Rows.Count).End(xlUp).Offset(1, 0).Row).Value = .Rows(rngCell.Row).Value End If Next i Next End With End Sub 

使用多张纸时，将所有范围限定在各自的纸张上非常重要。 我已经用With Block和直接与范围做到了这一点。

此外，只发布值时，可以更简单地直接分配值，而不是复制/粘贴。

另外，避免使用.Select或.Activate会减慢代码。

我还设置了一个工作表variables的目标表，所以长线有点短。