VBA to copy data if multiple criteria are met

Question

I am trying to create a VBA code which copies into Sheet "Results" the data in the third column of the below tab when the criteria "Lukas" in the first column and "Apple" in the second column are met. I know this could be done just using a VLOOKUP with multiple criteria but the data source length usually changes and I need the macro to do the check from ROW 2 until the last visible ROW.

According to my example, I should find the values 8 and 5 in the second sheet after running the macro. Below is the code I have been writing which is not working however..

    Sub copy()

Dim LastRow As Long
Dim i As Long

LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To LastRow

If Worksheets("Sheet1").Cells(i, 1) = "Lukas" And Worksheets("Sheet1").Cells(i, 2) = “Apple” Then
 Worksheets("Sheet1").Cells(i, 3).Select
 Selection.copy
 Sheets("Sheet2").Select
 Range(Cells(1, 1)).PasteSpecial xlPasteValues

End If
Next i

End Sub

Answer 1

This should do the trick:

Sub Selectivecopy()

Dim LastRow As Long
Dim i As Long
Dim j As Long

LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

j = 1
For i = 2 To LastRow

If Worksheets("Sheet1").Cells(i, 1) = "Lukas" And Worksheets("Sheet1").Cells(i, 2) = "Apple" Then
     Worksheets("Sheet2").Cells(j,1) = worksheets("Sheet1").Cells(i,3).Value
     j = j +1
End If
Next i

End Sub

You can directly set the value of a cell, using this line: Worksheets("Sheet2").Cells(j,1) = worksheets("Sheet1").Cells(i,3).Value. Just increment jevery time you do so to paste the values below each other.

If you want this to continue under the last cell when you run your code a second time you will have to replace j = 1 with a lastrow approach for sheet 2 as well.

Also you use a lot of select and activesheets, it would be better to avoid that, for examples see: How to avoid using Select in Excel VBA , in your case you should use: Lastrow = Worksheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row

Answer 2

Don't call your sub procedure Copy(). Call it anything else.

Choose a different destination or you are just going to overwrite the values you are transferring across.

Sub copyLukasAndApple()

    Dim LastRow As Long, i As Long, ws2 as worksheet

    with Worksheets("Sheet1")
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row

        For i = 2 To LastRow

            If .Cells(i, 1) = "Lukas" And .Cells(i, 2) = “Apple” Then
                with workSheets("Sheet2")
                    .cells(.rows.count, "A").end(xlup).offset(1, 0) = _
                         Worksheets("Sheet1").Cells(i, 3).value
                end with
            End If

        Next i
    end with

End Sub

Answer 3

I'm posting this only because it uses a different approach, AutoFilter, so you can do it one fell swoop.

Sub x()

Dim r As Range

Application.ScreenUpdating = False

With Worksheets("Sheet1")
    .AutoFilterMode = False
    .Range("A1").AutoFilter Field:=1, Criteria1:="=Lukas"
    .Range("A1").AutoFilter Field:=2, Criteria1:="=apple"
    With .AutoFilter.Range
        On Error Resume Next
        Set r = .Resize(.Rows.Count - 1, 1).Offset(1, 2).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not r Is Nothing Then
            r.copy Worksheets("Sheet2").Range("A1")
        End If
    End With
    .AutoFilterMode = False
End With

Application.ScreenUpdating = True

End Sub

Answer 4

Any particular reason you want to do this with VBA, instead of a good old PivotTable?

Here's how.

Select a cell in your range and turn it into an Excel Table using the Ctrl+T keyboard shortcut:

Select a cell in the resulting Table and turn it into a PivotTable by choosing Insert>PivotTable

This gives you an empty PivotTable 'canvas' on a new sheet:

Add all three fields to the ROWS area, and either filter them as required using the filter dropdowns in the PivotTable or by adding Slicers as I've shown here:

Any time you add more data to the initial sheet, simply right-click on the PivotTable to refresh it to include the new data.