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 \"Appl

Answer 1

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.

Answer 2

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 3

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 4

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