Change cell color to color of adjacent cell

[navic99]

I have a grid of text and numbers. Column A is all text and column B is all numbers. Column C is text, column D is numbers. E is text, F is numbers, etc.

I'm using the VBA code below to change to the color of the numbered cells based on the value. These are columns B, D, F, etc. What I want to do is change the text cell to the same color as its adjacent number cell. So, if cell B1 is blue, I want A1 to be blue. If D2 is yellow, I want C2 to be yellow, etc. If D3 has no color, then C3 should have no color.



Dim Cell As Range
Dim Rng1 As Range

On Error Resume Next
Set Rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
On Error GoTo 0
If Rng1 Is Nothing Then
Set Rng1 = Range(Target.Address)
Else
Set Rng1 = Union(Range(Target.Address), Rng1)
End If
For Each Cell In Rng1
Select Case Cell.Value
Case vbNullString
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
Case -500 To -30
Cell.Interior.ColorIndex = 3
Case -30 To -15
Cell.Interior.ColorIndex = 6
Case 15 To 30
Cell.Interior.ColorIndex = 34
Case 30 To 500
Cell.Interior.ColorIndex = 50
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
End Select
Next

End Sub

[Simon Lloyd]

Replace the case statement with this:Case vbNullString
Cell.Interior.ColorIndex = xlNone
Cell.Offset(0, 1).Interior.ColorIndex = xlNone
Cell.Font.Bold = False
Case -500 To -30
Cell.Interior.ColorIndex = 3
Cell.Offset(0, 1).Interior.ColorIndex = 3
Case -30 To -15
Cell.Interior.ColorIndex = 6
Cell.Offset(0, 1).Interior.ColorIndex = 6
Case 15 To 30
Cell.Interior.ColorIndex = 34
Cell.Offset(0, 1).Interior.ColorIndex = 34
Case 30 To 500
Cell.Interior.ColorIndex = 50
Cell.Offset(0, 1).Interior.ColorIndex = 50
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Offset(0, 1).Interior.ColorIndex = xlNone
Cell.Font.Bold = False
End Select

[navic99]

Perfect, thanks!

I changed it to (0, -1) since I was changing the cells to the left and not the right. Excellent!

[Bob Phillips]

Wouldn't it just be



Dim Cell As Range
Dim Rng1 As Range

On Error Resume Next
Set Rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
On Error GoTo 0
If Rng1 Is Nothing Then
Set Rng1 = Range(Target.Address)
Else
Set Rng1 = Union(Range(Target.Address), Rng1)
End If
For Each Cell In Rng1

Cell.Interior.ColorIndex = Cell.Offset(0, -1).Interior.ColorIndex
Next