Compare values inside the range (sheet1) and copy the row to new sheet (sheet2)

[bablugablu]

Hello everybody,

I am very new to vba and learning. I have a task where I need to compare the cell value to <71.002 or >71.014, Range G4:R4, also S4:AJ4 to <57.3 or >57.312. Sheet name is "Second Op". If any of the condition met then copy that Row (whole) to New sheet called "OverUnder PUN". Start pasting from Row4. As we are comparing and meeting the condition, needs to keep adding Rows for that.

Comparing Rows start at Row 4 and need to do till all the rows are done comparing at "Second Op".

Any help is appreciated.

Thank you

[mdmackillop]

Can you post your workbook. Go Advanced/Manage Attachments

[bablugablu]

here is the file

[wnazzaro]

I didn't look at the spreadsheet, but this should get you close.


Public Sub CompareData()
'Start at 4, need to know where to end
Dim EndRow As Integer
EndRow = Sheets("Second Op").Cells(Rows.Count, 7).End(xlUp).Row

'Loop through each field with the conditions, through each row
Dim r As Integer, f As Range
Dim newRow As Integer

'Start at row 4
r = 4

'Start the copying at row 2
newRow = 2

'Tracks whether this row has already been copied.
Dim CopyRow As Boolean
CopyRow = False

For r = 4 To EndRow

'Start with the first condition
For Each f In Sheets("Second Op").Range("G" & r & ":R" & r)
If CopyRow = True Then Exit For

If f.Value > 71.002 And f.Value < 71.014 Then
CopyRow = True
Worksheets("Second Op").Rows(r).Copy Destination:=Worksheets("OverUnder PUN").Rows(newRow)
newRow = newRow + 1
End If
Next f

'Then check the next condition
For Each f In Sheets("Second Op").Range("S" & r & ":AJ" & r)
'If this row has already been copied, no need to check again.
If CopyRow = True Then Exit For

'Check the second condition
If f.Value > 57.3 And f.Value < 57.312 Then
Worksheets("Second Op").Rows(r).Copy Destination:=Worksheets("OverUnder PUN").Rows(newRow)
newRow = newRow + 1
End If
Next f

CopyRow = False
Next r

End Sub

[bablugablu]

Thank you

I am going to try out and post the results

[bablugablu]

Tried now and it works beautiful.

Thank you for your quick help.

[mdmackillop]

This uses Column A to hold a temporary value for filtering

Sub Test()

Set ws1 = Sheets("Second Op")
Set r = ws1.Range("G4:R4")
Set s = ws1.Range("S4:AJ4")
With Application
rws = .CountA(Columns(3))
For i = 0 To rws - 1
x = .CountIf(r.Offset(i), "<71.002") + .CountIf(r.Offset(i), ">71.014") + _
.CountIf(s.Offset(i), "<57.3") + .CountIf(s.Offset(i), ">57.312")
If x > 0 Then Cells(4 + i, 1) = "x"
Next
End With
Set ws2 = Sheets.Add(after:=Sheets(Sheets.Count))
ws2.Name = "OverUnder PUN"
With ws1.Columns(1)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="<>"
.SpecialCells(xlCellTypeVisible).EntireRow.Copy ws2.Range("A4")
.ClearContents
End With
ws2.Columns(1).ClearContents
End Sub

[bablugablu]

Let me try out this new code also.

[bablugablu]

Getting this error.

Run Time error '424'
Object required

when click on debug, it highlight the ws2.Name = "OverUnder PUN"

[mdmackillop]

Try Worksheets instead of Sheets. If this fails, at least you already have a solution.

Sub Test()

Set ws1 = Worksheets("Second Op")
Set r = ws1.Range("G4:R4")
Set s = ws1.Range("S4:AJ4")
With Application
rws = .CountA(Columns(3))
For i = 0 To rws - 1
x = .CountIf(r.Offset(i), "<71.002") + .CountIf(r.Offset(i), ">71.014") + _
.CountIf(s.Offset(i), "<57.3") + .CountIf(s.Offset(i), ">57.312")
If x > 0 Then Cells(4 + i, 1) = "x"
Next
End With
Set ws2 = Worksheets.Add(after:=Worksheets(Worksheets.Count))
ws2.Name = "OverUnder PUN"
With ws1.Columns(1)
.AutoFilter
.AutoFilter Field:=1, Criteria1:="<>"
.SpecialCells(xlCellTypeVisible).EntireRow.Copy ws2.Range("A4")
.ClearContents
End With
ws2.Columns(1).ClearContents
End Sub

[bablugablu]

The first one work beautiful.

I am going to stick with that code.

Thanks for your help.

[bablugablu]

One more request if possible.

I have attached the picture for the request.

Basically what extra request came is to match up OverUnder Pun (Column C - number) with corresponding number on First OP. Copy the Row and build under.
If more than one instances of match found then add corresponding rows and leave one row empty underneath.

Repeat till all Column C is inquired upon in sheet OverUnder PUN.

P.S. I am attaching the original file. I have modified one line to take out "Simulatedpun"

[bablugablu]

Public Sub MatchSecondToFirst()
Dim EndRow, EndRow1 As Integer
EndRow = Sheets("OverUnder PUN").Cells(Rows.Count, 3).End(xlUp).row
EndRow1 = Sheets("First Op").Cells(Rows.Count, 3).End(xlUp).row

Worksheets("MatchSecondToFirst").Range("A1:ZZ65000").ClearContents

'Loop through each field with the conditions, through each row
Dim r, b As Integer
Dim newRow As Integer

'Start at row 4
r = 4

'Start the copying at row 4
newRow = 4
For r = 4 To EndRow

Worksheets("OverUnder PUN").Rows(r).Copy Destination:=Worksheets("MatchSecondToFirst").Rows(newRow)
newRow = newRow + 1

For b = 4 To EndRow1

If Sheets("OverUnder PUN").Range("C" & r).Value = Sheets("First Op").Range("C" & b).Value Then
Worksheets("First Op").Rows(b).Copy Destination:=Worksheets("MatchSecondToFirst").Rows(newRow)
newRow = newRow + 1

End If

Next b

newRow = newRow + 1

Next r
End Sub