Copy cell background color and paste it to corresponding cell of another sheet

Question

I have values on Sheet 1 and I gave the background color using conditional formatting.

I want to copy only the color and paste it to the corresponding cell of sheet 2 without pasting the value.

Example if sheet 1 cell A1 has red color for specific value, transfer the color to sheet 2 A1.

I use two colors, red and white. Red is for higher value and white is for lower value.

Sub copycolor()
    Dim intRow As Integer
    Dim rngCopy As Range
    Dim rngPaste As Range

    For intRow = 1 To 20

        Set rngCopy = Sheet1.Range("A" & intRow + 0)
        Set rngPaste = Sheet2.Range("b" & intRow)

        'Test to see if rows 500+ have a value
        If rngCopy.Value <> "" Then

            'Since it has a value, copy the value and color
            rngPaste.Value = rngCopy.Value
            rngPaste.Interior.Color = rngCopy.Interior.Color

        End If
    Next intRow
End Sub

Answer 1

rngPaste.Interior.Color = rngCopy.DisplayFormat.Interior.Color

Seems to work for me. Keep in mind that DisplayFormat is read-only and is not allowed to return value outside of the function it's used in. Also it is only available in Excel 2010 +

I was editing my answer to include the other stuff you mentioned and realized it was getting confusing to explain it all in separate chunks. Here's a recommended approach to achieve what you're saying.

Public Sub CopyColor()
Dim SourceSht As Worksheet
Dim TargetSht As Worksheet
Dim rngCopy As Range
Dim rngPaste As Range
Dim LastCopyRow As Long
Dim LastCopyColumn As Long

'Define what our source sheet and target sheet are
Set SourceSht = ThisWorkbook.Worksheets("Sheet1")
Set TargetSht = ThisWorkbook.Worksheets("Sheet2")

'Find our used space on the source sheet
LastCopyRow = SourceSht.Cells(Rows.Count, "A").End(xlUp).Row
LastCopyColumn = SourceSht.Cells(1, Columns.Count).End(xlToLeft).Column

'Setup our ranges so we can be sure we don't loop through unused space
Set rngCopy = SourceSht.Range("A1:" & SourceSht.Cells(LastCopyRow, LastCopyColumn).Address)
Set rngPaste = TargetSht.Range("A1:" & TargetSht.Cells(LastCopyRow, LastCopyColumn).Address)

'Loop through each row of each column.
' This will go through each cell in column 1, then move on to column 2
For Col = 1 To LastCopyColumn
    For cel = 1 To LastCopyRow
        ' If the string value of our current cell is not empty.
        If rngCopy.Cells(cel, Col).Value <> "" Then
            'Copy the source cell displayed color and paste it in the target cell
            rngPaste.Cells(cel, Col).Interior.Color = rngCopy.Cells(cel, Col).DisplayFormat.Interior.Color
        End If
    Next cel
Next Col
End Sub

Answer 2

Simplest would be to apply the same conditional formatting to Sheet2, but use the values from Sheet1 as your criteria. So if Sheet1 Cell A1 has the value that makes it red, add formatting to Sheet2 that turns Sheet2 Cell A1 red as well.

There's a good explanation of how to achieve this here.

Answer 3

.Interior.Color gets the actual colour of the cell rather than the conditionally formatted colour (the one you see). So you can't copy/paste this red colour in your example in this way.

I believe that the only way to get the conditionally formatted colour you see would be to recompute whatever formula you've used in your conditionally formatting criteria.

Excel 2007 conditional formatting - how to get cell color?

Edit

While @JeffK627 was giving an elegant solution, I was knocking up some rough vba code to recompute what I gather your conditional formatting does. I've done this over range A1:A20 on sheet 2. At the moment it colours the cell that contains the value itself, but only requires a little tweak to colour the equivalent cell on another sheet.

Sub ColouringIn()

    Dim intColIndex As Integer
    Dim dblMax As Double
    Dim dblMin As Double
    Dim rngCell As Range

    'RGB(255, 255, 255) = white
    'RGB(255, 0, 0) = red
    'so need to extrapolate between

    dblMax = Application.WorksheetFunction.Max(Sheet2.Range("A1:A20"))
    dblMin = Application.WorksheetFunction.Min(Sheet2.Range("A1:A20"))

    For Each rngCell In Sheet2.Range("A1:A20")
        If IsNumeric(rngCell.Value) And rngCell.Value <> "" Then
            intColIndex = (rngCell.Value - dblMin) / (dblMax - dblMin) * 255
            rngCell.Interior.Color = RGB(255, intColIndex, intColIndex)
        End If
    Next rngCell

End Sub

Answer 4

Adding following example as alternative solution, as I needed something dynamic/active where color IS a required condition of data & not reliant on any other trigger.

Option1:

Dim rngPrev2Update As Range

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim cellbox As Range
    Dim rngDest As Range

    If Not rngPrev2Update Is Nothing Then
    For Each cellbox In rngPrev2Update.Cells
        Worksheets("Sheet2").Range(cellbox.Address).Interior.ColorIndex = cellbox.Interior.ColorIndex
    Next cellbox
    End If
    Set rngPrev2Update = Target

End Sub

This will update destination cells when cursor is next moved to another cell.

Option2:

Private Sub Worksheet_Activate()

    Dim cellbox As Range
    Dim rngCells As Range
    Set rngCells = Range("B1:B10")

    For Each cellbox In rngCells.Cells
        Range(cellbox.Address).Interior.ColorIndex = Worksheets("Sheet2").Range(cellbox.Address).Interior.ColorIndex
    Next cellbox

End Sub

Will update relevant cells on sheet load.

Note: If you have very large data set you may want to put this into a macro button &/or filter this further for only the cells you need, otherwise this may slow your spreadsheet down.

Answer 5

Appreciating this was some time ago. I would like to do a similar thing however would like to append the Interior Color Reference ie. 255 to the cells value.

so if cell A1 has Hello in the cell and is Colored Red I'd want in the other worksheet cell A1: Hello | 255

Just used | as a delimiter but anything sensible...