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

there is an edit button at the bottom left of your question. — Luuklag, Jul 06 '18 at 13:13

Luuklag · Answer 1 · 2018-07-06T13:40:09.287

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

I only caught it from adding `Option Explicit` when VBE asked me to declare that as a variable (+1 though) — urdearboy, Jul 06 '18 at 13:21
Always good to add option explicit. I didn't even put this into VBA, so thats where you caught me ;) — Luuklag, Jul 06 '18 at 13:22

score 5 · Accepted Answer · 2018-07-06T13:20:59.707

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

Elegant way to avoid a second counter. – Luuklag Jul 06 '18 at 13:21 — Luuklag, Jul 06 '18 at 13:21

SJR · Answer 3 · 2018-07-06T14:49:24.250

4

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

edited Jul 06 '18 at 14:49

answered Jul 06 '18 at 13:22

SJR

22,986
6
18
26

Nice way as well. Probably saves time when the rows to be copied turn into the thousands. – Luuklag Jul 06 '18 at 13:24
1

@Luuklag - thanks. It does, although in my experience looping is generally ok unless you have huge amounts of data. – SJR Jul 06 '18 at 13:27
1

As an aside, you should resize before offset. e.g. `Set r = .Resize(.Rows.Count - 1, 1).Offset(1, 2)....` In the off-chance that the filter range mistakenly goes to the bottom of the worksheet (e.g. Range("A:C").AutoFilter), putting offset first will crash. It's rare but we've had that problem around here a few times and it's almost impossible to diagnose. – Jul 06 '18 at 13:30

score 1 · Answer 4 · answered Jul 06 '18 at 16:09

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.

VBA to copy data if multiple criteria are met

4 Answers4

Linked