將基於多個條件的行從一個工作表復制到另一個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