VBA If with two criteria in two columns - vba

Question

I need to look at two cells (C and F) on a each row, and if the value for C to ends with 30 and the value for F is greater than Zero, copy and paste the row to another sheet. I've managed to get the copy and paste to work using 1 criteria, but I cannot figure out how to get both criteria to work together.
Sub compile1()
Dim x As String
Set rSearch = Sheets("Application").Range("C:C")
For Each cell In rSearch
x = cell.Value
If Right(cell, 2) = "30" And cell.Offset(, 3) > 0 Then
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("sheet2").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Application").Select
End If
Next
End Sub

Answer 1

Here you go:
Sub CP()
Dim i As Long
Dim n As Long
n = Sheets("Application").Cells(Rows.Count, 3).End(xlUp).Row
For i = 1 To n
With Sheets("Application")
If Right(Cells(i, 3), 2) = 30 And Cells(i, 6).Value > 0 Then
.Cells(i, 3).EntireRow.Copy Destination:=Sheets("Sheet3").Cells(i, 3)
.Cells(i, 6).EntireRow.Copy Destination:=Sheets("Sheet3").Cells(i, 6)
End If
End With
Next i
End Sub
I have used column 3 to count the number of rows and hence assumed this is the main column

Answer 2

You were missing the Next statement in your second for each loop.
The two criterias can be taken together with this line:
If y > 0 And Right(x, 2) = "30" Then
so the whole code would be...
Sub compile1()
Dim x As String
Dim y As Integer
Dim rSearch As Range
Dim rSearch1 As Range
Dim cell As Range, cell1 As Range
Dim matchRow As Integer
Set rSearch = Sheets("Application").Range("C:c")
Set rSearch1 = Sheets("Application").Range("F:F")
For Each cell In rSearch
x = cell.Value
For Each cell1 In rSearch1
y = cell1.Value
If y > 0 And Right(x, 2) = "30" Then
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("sheet2").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Application").Select
End If
Next cell1
Next cell
End Sub

Answer 3

To speed things up I'd suggest the following:
Sub Copy_Paste()
Dim x As String
Dim y As Integer
Dim WS1 As Worksheet
Set WS1 = ActiveSheet
y = 1
Do Until y > WorksheetFunction.Max(Range("C1048576").End(xlUp).Row, Range("F1048576").End(xlUp).Row)
x = Trim(Cells(y, 3).Value)
If Right(x, 2) = "30" And (IsNumeric(Cells(y, 6).Value) And Cells(y, 6).Value > 0) Then Rows(y & ":" & y).Copy: Sheets("Sheet2").Range("A" & Sheets("Sheet2").Range("C1048576").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False: Application.CutCopyMode = False
y = y + 1
Loop
Sheets("Sheet2").Activate
Range("A1").Activate
WS1.Activate
End Sub

Answer 4

Try this code once - this is way too simpler and optimized processing than loops (slower)
Application.ScreenUpdating = False
Application.EnableEvents = False
Sheets("Application").AutoFilterMode = False
Dim lastrow, lastcol As Integer
lastrow = Range("F500000").End(xlUp).Row
lastcol = Sheets("Application").Range("A1").End(xlToRight).Column + 1
Sheets("Application").Cells(1, lastcol).Value = "helper"
Sheets("Application").Range(Sheets("Application").Cells(1, lastcol),Sheets("Application").Cells(lastrow, lastcol)).FormulaR1C1 = "=Right(RC[-1],2)"
Sheets("Application").Range(Range("A1"), Range("A1").End(xlToRight)).AutoFilter Field:=lastcol, Criteria1:="30"
Sheets("Application").Range(Range("A1"), Range("A1").End(xlToRight)).AutoFilter Field:=3, Criteria1:=">0"
Sheets("Application").Range(Cells(1, 1), Cells(lastrow, lastcol)).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheet2.Range("A2")
Columns(lastcol).Delete
Application.ScreenUpdating = True
Application.EnableEvents = True

Answer 5

Here is the entire code. It works but takes ages to run. Any help to speed it up would be appreciated.
Sub Master()
Call compile1
Call compile2
End Sub
Sub compile1()
For Each cell In Sheets("Application").Range("C:C")
If Right(cell.Value, 2) = "10" Then
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Routine w credits").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Application").Select
End If
Next
For Each cell In Sheets("Application").Range("C:C")
If Right(cell.Value, 2) = "20" Then
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Reactive w credits").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Application").Select
End If
Next
End Sub
Sub compile2()
Set rSearch = Sheets("Application").Range("C:C")
For Each cell In rSearch
If Right(cell, 2) = "20" And cell.Offset(, 3) > 0 Then
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Reactive wo credits").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Application").Select
End If
Next
For Each cell In rSearch
If Right(cell, 2) = "10" And cell.Offset(, 3) > 0 Then
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Routine wo credits").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Application").Select
End If
Next
End Sub

Answer 6

Sub compile1()
Dim Cel As Range, Rng As Range
Set rSearch = Sheets("Application").Columns("C:C").SpecialCells(xlCellTypeConstants, 23)
For Each Cel In rSearch
If Right(Trim(Cel.Value), 2) = "30" And (Cel.Offset(, 3).Value > 0) Then
Cel.EntireRow.Copy
Sheets("Sheet2").Range("A" & Sheets("Sheet2").Range("C1048576").End(xlUp).Row + 1).Paste
Application.CutCopyMode = False
End If
Next
End Sub