copy/paste based on colour criteria
 

Hello to all

I am running a code at the moment that copies/pastes based on selection criteria within my workbook and would like to add to it. I have 2 criteria to add if possible????

The code below is fine but i would like to add the following

if within a row, column D is greater than 1 AND red, copy column A to column B.....and column D (content only) to column F. This is all to the same sheet as the rest of the code....VKnew. The tricky bit is, the row to start pasting may vary. The heading it should paste under is 'optionals/non-discount'

Is this possible? Do i have to nominate a row to start pasting from??? COuld someone write a separate code that only performs the function i have requested...maybe thats a better way??

Cheers to all!!!
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 Rang
Dim nrow As Long, rw As Lon
Dim col As Strin
Dim Sh As Workshee
Set rng = Range("D9:D94"
nrow = Application.CountIf(rng, "0"
Set Sh = Worksheets("VK new"
rw = 1
For Each cell In Range("D9:D98"
If Cells(cell.Row, "D").Interior.ColorIndex = 3 The
col = "G
Els
col = "F
End I
If Not IsEmpty(cell) The
If IsNumeric(cell) The
If cell 0 The
Cells(cell.Row, 1).Cop
Sh.Cells(rw, "A").PasteSpecial Paste:=xlPasteValue
Cells(cell.Row, 4).Cop
Sh.Cells(rw, col).PasteSpecial Paste:=xlPasteValue
Cells(cell.Row, 2).Cop
Sh.Cells(rw, "B").PasteSpecial Paste:=xlPasteValue
rw = rw +
End I
End I
End I
Nex
End Sub