Copy and Paste based on 2 Criteria

[Steves73]

Hi Guys,

Code below was supplied by a member and works perfectly, however would like to expand if possible

As per anything new, once we see it work then expanding comes to mind.

So, was wondering, is it possible to have the below code use 2 Criteria for copy and paste?


Type a criteria in Cell A2, the code looks for a match or matches in column “B”

Type a criteria in Cell B2, the code looks for a match or matches in column “K”



Once both criteria are met, it copies and pastes the matching rows to sheet2 – Next blank line

The VBA Code supplied (Which is great) copies lines based on a "yes" on column K


Private Sub CommandButton1_Click()
Const cdblColToCheck As Double = 11 ' Check in column K for a 'Yes'.
Dim dblOneLastRow As Double
Dim dblTwoLastRow As Double
Dim dblOneRow As Double
'
With Worksheets("Sheet2")
dblTwoLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With Worksheets("Sheet1")
.Activate
dblOneLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For dblOneRow = 2 To dblOneLastRow
If .Cells(dblOneRow, cdblColToCheck).Value = "Yes" Then
dblTwoLastRow = dblTwoLastRow + 1
.Rows(dblOneRow).Copy Destination:=Worksheets("Sheet2").Cells(dblTwoLastRow, 1)
End If
Next
Application.CutCopyMode = False
.Cells(1, 1).Select
End With
End Sub

 

[Fluff]

How about

Sub Steves()
   Dim Ws As Worksheet
   
   Set Ws = Sheets("Sheet1")
   With Sheets("Sheet2")
      .Range("A1:K1").AutoFilter 2, Ws.Range("A2").Value
      .Range("A1:K1").AutoFilter 11, Ws.Range("A2").Value
      .AutoFilter.Range.Offset(1).EntireRow.Copy Ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
      .AutoFilterMode = False
   End With
End Sub

 

[Steves73]

Hi All.

I am getting a run time error on the below line in the code

.Range("A1:K1").AutoFilter 2, Ws.Range("A2").Value

New to VBA so not sure why, have attached my spread sheet below showing the criteria cells for the copy and paste (Cell A2 and B2)

Just to clarify, the codle looks is cells A2 and B2, searches the data below these cells, finds line 5 and 9 and copies all the data in the lines to sheet 2

Hope this helps

 

[Fluff]

How about

Sub Steves()
   Dim Ws As Worksheet
   
   Set Ws = Sheets("Sheet2")
   With Sheets("Sheet1")
      .Range("A4:K4").AutoFilter 2, .Range("A2").Value
      .Range("A4:K4").AutoFilter 11, .Range("B2").Value
      .AutoFilter.Range.Offset(1).EntireRow.Copy Ws.Range("A" & Rows.Count).End(xlUp).Offset(1)
      .AutoFilterMode = False
   End With
End Sub

 

[Steves73]

Hi Mate

Code works perfectly

Thank you very much

 

[Fluff]

You're welcome & thanks for the feedback