将基于多个条件的行从一个工作表复制到另一个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 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会减慢代码速度。

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

Answer 2

使用自动过滤器的另一种方法，以避免产生循环。 为清楚起见，评论如下：

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