Copy Rows Based On Multiple Criteria from one Worksheet to Another VBA

Question

I'm trying to copy rows from Inventory sheet to Fruit sheet, but the codes below keeps copy and pasting in the same sheet. I have no idea how to change this. Can someone help me please? thanks in advance for any help!!

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

Try this:

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

When using multiple sheets it is important to qualify all ranges to their respective sheet. I have done this with the With Block and directly with the ranges.

Also when only posting values it is quicker to simple assign the values directly instead of copy/paste.

Also, avoid using .Select or .Activate it will slow down the code.

I also set a worksheet variable to the target sheet so the long line is a little shorter.

Answer 2

Alternate method using autofilter to avoid having a loop. Commented for clarity:

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