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

Question

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

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

使用自动筛选以避免循环的替代方法。 为清楚起见，评论如下：

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它会减慢代码速度。

我还为目标工作表设置了一个工作表变量，因此长行更短一些。