Addition to code

[gav meredith]

Hello all,

with the following code and same criteria, is it possible to amend so as to
have info also copy from column A (sheet pricing) to column B (sheet VKnew)
and column D (sheet pricing) to column F (sheet VKnew). Simply, i would like
the data to copy/paste as is but also perform the requested function aswell.
I would like the data to paste under the heading "optionals/non-discounted".
If this cannot be done, i may be adble to nominate a cell. (IE:B83 and F83)

thank you in advance

Private Sub CommandButton3_Click()
CopyData Range("D913"), "FEEDER"
CopyData Range("D1658"), "MACHINE"
CopyData Range("D6373"), "DELIVERY"
CopyData Range("D7882"), "PECOM"
CopyData Range("D8894"), "ROLLERS"
CopyData Range("D104128"), "MISCELLANEOUS"
Dim rng As Range, cell As Range
Dim nrow As Long, rw As Long
Dim col As String
Dim Sh As Worksheet
Set rng = Range("D994")
nrow = Application.CountIf(rng, ">0")
Set Sh = Worksheets("VK new")
'Debug.Print Sh.Range("A10").Resize(nrow * 1, 1).EntireRow _
..Address(external:=True)
' **to insert lines to accommodate new data _
activate the line below by removing " ' "**
'Sh.Range("A10").Resize(nrow * 1).EntireRow.Insert
' ** the line below will clear earlier data **
'Sh.Range("A10:G99").ClearContents
rw = 10
For Each cell In Range("D998")
If Cells(cell.Row, "D").Interior.ColorIndex = 3 Then
col = "G"
Else
col = "F"
End If
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, col).PasteSpecial Paste:=xlPasteValues
' **above four lines can be replaced with these lines**
'Cells(cell.row, 1).Copy Sh.Cells(rw, "A")
'Cells(cell.row, 4).Copy Sh.Cells(rw, col)
' **If you don't have formulas in Column A & D**
rw = rw + 1
End If
End If
End If
Next