Find value with criteria then copy row

[sharky12345]

I'm using this to find a value in a range subject to criteria;

Lastrow = Range("A65536").End(xlUp).RowFor Each cell In Range("A2:A" & Lastrow)


Set r = Sheet4.Cells.Find(What:=cell, After:=[B1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
If Not r Is Nothing Then


cell.Offset(0, 1) = Sheet4.Range("D" & r.Row).Value
cell.Offset(0, 2) = Sheet4.Range("E" & r.Row).Value
cell.Offset(0, 3) = Sheet4.Range("F" & r.Row).Value
cell.Offset(0, 4) = Sheet4.Range("G" & r.Row).Value
cell.Offset(0, 5) = Sheet4.Range("H" & r.Row).Value
cell.Offset(0, 6) = Sheet4.Range("I" & r.Row).Value
cell.Offset(0, 7) = Sheet4.Range("C" & r.Row).Value


End If


Next

It works fine, but it takes a while to execute on a large sheet - so is there a quicker of easier way to do it, perhaps using copy and paste?

 

[123DavidRhodes]

If that's your entire code I would put this line in first and it will speed up significantly:

Application.ScreenUpdating = False