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