Re-post of existing problem

G

gav meredith

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()
 
C

chris

Try this
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 Sh As Workshee
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.Inser
rw = 1
For Each cell In Range("D9:D98"
If Not IsEmpty(cell) The
If IsNumeric(cell) The
If cell > 0 The

'***********This is where your code should go *************
If cell(cell.Row, "C").Interior.ColorIndex = 3
And cell.Value > 1 The
Cells(cell.Row, "G").Value = cell.Valu
'Cells(cell.Row, "G").Interior.ColorIndex = 3 '??
GoTo NextCell: 'This is the out for cell meeting special criteria: Moves it to Nex
End I
'***********************************************************

Cells(cell.Row, 1).Cop
Sh.Cells(rw, "A").PasteSpecial Paste:=xlPasteValue
Cells(cell.Row, 4).Cop
Sh.Cells(rw, "F").PasteSpecial Paste:=xlPasteValue
rw = rw +
End I
End I
End I
NextCell: '***
Nex
End Su

----- gav meredith wrote: ----

Hi

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

Sub Checker(
Dim cell as rang
For Each cell In Range("D9:D98"
If Not IsEmpty(cell) The
If IsNumeric(cell.Value) The
If cell(cell.row, "C").Interior.ColorIndex = 3
And
cell.Value > 1 The
cells(cell.Row,"G").Value = Cell.Valu
End I
End I
End I
Nex

End Su

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

Private Sub CommandButton3_Click(
 
G

gav meredith

thanks for the reply chris

That didnt seem to work unfortunately. Let me try and explain it a bit better. The current code pastes from a sheet quote2 to a sheet called vknew. Users select items on quote2 by inserting a '1'. If the cell calue in column D is greater than '1', then column A and D pastes to vknew colums A and F. What i need is, if column C on quote2 where the selctions are made is highlighted red, then the data from column D is to paste to column G instead of column F (vknew). Basically, the cell being red is to provide a point of differentiation for the user and this should reflect on Vknew by showing a figure in an alternate column

Another idea???? Thanks chris!!!!!
 
C

Cecilkumara Fernando

gav meredith,
Try this
Sub Checker()
Dim cell As Range
Dim col As String
For Each cell In Range("D9:D98")
If Cells(cell.row, "C").Interior.ColorIndex = 3 Then
col = "G"
Else
col = "F"
End If
If Not IsEmpty(cell) Then
If IsNumeric(cell.Value) And _
cell.Value > 1 Then
Cells(cell.row, col).Value = cell.Value
End If
End If
Next
End Sub

HTH
Cecil
 
P

Paul Robinson

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
 
C

Cecilkumara Fernando

gav meredith,
Hope this is what you want

Private Sub CommandButton3_Click()
'what is this copydata it is not working for me
'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 col As String
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)
' **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("D9:D98")
If Cells(cell.row, "C").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
End Sub

HTH
Cecil
 
G

gav meredith

Hi all

i seem to be causing some confusion as to what i am trying to achieve. Thank you to those who have provided responses but unfortunately i cannot seem to implement these into my workbook or existing code. This is probably my error. All i can suggest is to send my workbook to someone for a more hands on approach. Is anyone up for the challenge???

Thanks all!!!!
 
Top