VBA to extract from all row matching the condition

[abdulncr]

Hi friends,

I have below VBA to extract the row if matching criteria, but it is not working if criteria matches other than first row, please can have any change in the code


eg: if value greater than 5 in the AF18 it is working, if AF18 has value less than 5 and below there are cell greater than 5 code not working.


Sub COPYTO1()

Dim r As Range, sh As Worksheet

Set r = Worksheets("Extract").Range("AF18:AF200")

Set sh = Worksheets("1")

For Each cell In r

If (cell.Value) >= "5" Then

rw = sh.Cells(sh.Rows.count, "C").End(xlUp).Row + 1

cell.EntireRow.Copy

If rw < 18 Then rw = 18

sh.Cells(rw, 1).PasteSpecial xlValues

sh.Cells(rw, 1).PasteSpecial xlFormats

End If

Next

End Sub


Tanks

Abdul

 

[SirJB7]

Hi, abdulncr!

Do you have numeric or string values in column AF?

Regards!

 

[abdulncr]

SirJB7,


Yes i have always numeric in the AF.


Thanks

Abdul

 

[SirJB7]

Hi, abdulncr!

Then give a try changing this statement from:

If (cell.Value) >= "5" Then

to:

If (cell.Value) >= 5 Then

Regards!

 

[NARAYANK991]

Hi Abdul ,


The following works ; the only point is that you are checking for the last row by looking in column C ; if the cells in column C do not have data in any rows 18 through 200 , then there can be problems.

[pre]

Sub COPYTO1()
Dim r As Worksheet, sh As Worksheet
Set r = ThisWorkbook.Worksheets("Extract")
Set sh = Worksheets("1")
r.Activate
Range("AF18:A200").Select
For Each cell In Selection
If (cell.Value) >= "5" Then
rw = sh.Cells(sh.Rows.Count, "C").End(xlUp).Row + 1
cell.EntireRow.Copy
If rw < 18 Then rw = 18
sh.Cells(rw, 1).PasteSpecial xlValues
sh.Cells(rw, 1).PasteSpecial xlFormats
End If
Next
End Sub

[/pre]
Narayan

 

[abdulncr]

Thank you so much Narayan. it is working.