Differentiate between cell colours

G

gav meredith

Hello,

can someone please alter this code so that if a cell in column D is NOT red, then data pastes to column F instead of column G. Currently, rows with a red cell in column D paste to column A and G on sheet VKnew. I want the rows without a red cell in column D to paste to column F (not G) on VKnew.


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.Interior.ColorIndex = 3 And cell.Value > 0 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, "G").PasteSpecial Paste:=xlPasteValues
rw = rw + 1
End If
End If
End If
Next
End Sub


Thank you!!!!!!
 
C

Cecilkumara Fernando

gav meredith,
This is the answer I gave you for a earlier post only changed red cell checking from C to D
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, "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
End Sub

HTH
Cecil

Hello,

can someone please alter this code so that if a cell in column D is NOT red, then data pastes to column F instead of column G. Currently, rows with a red cell in column D paste to column A and G on sheet VKnew. I want the rows without a red cell in column D to paste to column F (not G) on VKnew.


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.Interior.ColorIndex = 3 And cell.Value > 0 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, "G").PasteSpecial Paste:=xlPasteValues
rw = rw + 1
End If
End If
End If
Next
End Sub


Thank you!!!!!!
 
G

gav meredith

that is exactly what i was after. I cant thank you enough!!!!!


gav meredith,
This is the answer I gave you for a earlier post only changed red cell checking from C to D
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, "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
End Sub

HTH
Cecil

Hello,

can someone please alter this code so that if a cell in column D is NOT red, then data pastes to column F instead of column G. Currently, rows with a red cell in column D paste to column A and G on sheet VKnew. I want the rows without a red cell in column D to paste to column F (not G) on VKnew.


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.Interior.ColorIndex = 3 And cell.Value > 0 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, "G").PasteSpecial Paste:=xlPasteValues
rw = rw + 1
End If
End If
End If
Next
End Sub


Thank you!!!!!!
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Whats wrong with this code 5
Alter code 0
Alter existing code 5
Additional column 0
Addition to code 0
additional target 1
copy/paste based on colour criteria 0
text inclusion 0

Top