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
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