Hi gav
I remember reading your original post, and it was extremely unclear
what you wanted - that is why nobody replied. This post is no
clearer...

regards
Paul
"gav meredith" wrote in message ...
Hi,

Within the following code, can someone please show me how to implement
this.....

Sub Checker()
Dim cell as range
For Each cell In Range("D9:D98")
If Not IsEmpty(cell) Then
If IsNumeric(cell.Value) Then
If cell(cell.row, "C").Interior.ColorIndex = 3 _
And _
cell.Value 1 Then
cells(cell.Row,"G").Value = Cell.Value
End If
End If
End If
Nexr

End Sub

This is the existing code that copies and pastes based on a cell value
greater than 1. What the above is supposed to accomplish is the same BUT a
red cell in columnC would paste to an alternate location. Thanks so much!!!!

Private Sub CommandButton3_Click()
CopyData Range("D9:D13"), "FEEDER"
CopyData Range("D16:D58"), "MACHINE"
CopyData Range("D63:D73"), "DELIVERY"
CopyData Range("D78:D82"), "PECOM"
CopyData Range("D88:D94"), "ROLLERS"
CopyData Range("D104:D128"), "MISCELLANEOUS"
Dim rng As Range, cell As Range
Dim nrow As Long, rw As Long
Dim Sh As Worksheet
Set rng = Range("D9:D94")
nrow = Application.CountIf(rng, "0")
Set Sh = Worksheets("VK new")
Debug.Print Sh.Range("A10").Resize(nrow * 1,
1).EntireRow.Address(external:=True)
' sh.Range("A10").Resize(nrow * 1).EntireRow.Insert
rw = 10
For Each cell In Range("D9:D98")
If Not IsEmpty(cell) Then
If IsNumeric(cell) Then
If cell 0 Then
Cells(cell.Row, 1).Copy
Sh.Cells(rw, "A").PasteSpecial
Paste:=xlPasteValues
Cells(cell.Row, 4).Copy
Sh.Cells(rw, "F").PasteSpecial
Paste:=xlPasteValues
rw = rw + 1
End If
End If
End If
Next
End Sub