Cange cell background colour based on contents of other cell

[Dave_P_C]

I have a spreadsheet which has text values in a left hand column and numeric values in the adjacent right hand column.

For example cells A1, C1, C3, C4, etc... could have the values "BH" or "SD" or "S" or "H" or "FH".

Cells B1, B2, B3, B4, etc... could have numeric values in them from 0.1 to 7.5.

Book1
	A	B	C	D	E	F
1	H	7.5	FH	2	S	7.5
2	SD	7.5	SD	3
3	SD	7.5
4
5			S	3.5
6	FH	3.5
7					S	7.5
8
9
10	BH	7.5	BH	7.5	BH
Sheet1

I already have VBA script that will set the background colour of all cells containing a text values to a certain colour.

For example, if cells A1, A3, A5 and A6 contained "BH" they would all be given a yellow background. Cells containing the value "H" would get a green background, cells containing "S" a Grey background, cells containing "SD" a purple background and cells containing "F" a blue background.

What I need to do is set the cell to the right of one containing a specific value to the same background colour.

For example if cells A5, C5, and E5 all contain "BH" and have yellow backgrounds I need cells B5, D5 and F5 to also be given yellow backgrounds.

The working VB Script I have so far to set a cell colour depending on the contents is :-

Sub SetCellColour()

Dim cell As Range
Dim Target As Range

For Each cell In ActiveSheet.Range("C13:U163")
If cell.Value = "F" Then
cell.Interior.ColorIndex = 8
cell.Interior.Pattern = xlSolid
cell.Interior.PatternColorIndex = xlAutomatic
ElseIf cell.Value = "SD" Then
cell.Interior.ColorIndex = 7
cell.Interior.Pattern = xlSolid
cell.Interior.PatternColorIndex = xlAutomatic
ElseIf cell.Value = "S" Then
cell.Interior.ColorIndex = 15
cell.Interior.Pattern = xlSolid
cell.Interior.PatternColorIndex = xlAutomatic
ElseIf cell.Value = "BH" Then
cell.Interior.ColorIndex = 6
cell.Interior.Pattern = xlSolid
cell.Interior.PatternColorIndex = xlAutomatic
ElseIf cell.Value >= 0.1 Then
cell.Interior.ColorIndex = 4
cell.Interior.Pattern = xlSolid
cell.Interior.PatternColorIndex = xlAutomatic
ElseIf cell.Value = "" Then
cell.Interior.ColorIndex = 0
cell.Interior.Pattern = xlSolid
cell.Interior.PatternColorIndex = xlAutomatic
End If
Next

End Sub

Could someone please let me know what additional script would have to be added in order to set the background colour of a cell on the right hand side (e.g. B10) with that to the one on the left (e.g. A10).

I have tried using the cell.offset but without success and I am not even sure if this is the correct approach.

Any help you could provide will be greatly appreciated.

Many thanks.

 

[shippey121]

i had a similar problem the other week and here is the answer i got

try

Private Sub Worksheet_Calculate() 

m = [c1].Value 
n = [d1].Value 
o = [e1].Value 
p = [f1].Value 
q = [g1].Value 
r = [h1].Value 
s = [i1].Value 

Range("a8:r100").Interior.ColorIndex = 0 
    For Each c In Range("c8:r100") 
        Select Case c.Value 
            Case m 
                Range(c, c.Offset(, 1)).Interior.ColorIndex = 44 
            Case n 
                Range(c, c.Offset(, 1)).Interior.ColorIndex = 39 
            Case o 
                Range(c, c.Offset(, 1)).Interior.ColorIndex = 4 
            Case p 
                Range(c, c.Offset(, 1)).Interior.ColorIndex = 5 
            Case q 
                Range(c, c.Offset(, 1)).Interior.ColorIndex = 6 
            Case r 
                Range(c, c.Offset(, 1)).Interior.ColorIndex = 7 
            Case s 
                Range(c, c.Offset(, 1)).Interior.ColorIndex = 8 
            Case Else 
                iCol = 0 
        End Select 
Next c 

End Sub

you need to alter the colorinex to suit and the select case too

HTH

 

[shippey121]

something like

Private Sub Worksheet_Change(ByVal Target As Range)
f = "f"
sd = "sd"
s = "s"
bh = "bh"

Range("a8:r100").Interior.ColorIndex = 0
    For Each c In Range("c8:r100")
        Select Case c.Value
            Case f
                Range(c, c.Offset(, 1)).Interior.ColorIndex = 44
            Case sd
                Range(c, c.Offset(, 1)).Interior.ColorIndex = 39
            Case s
                Range(c, c.Offset(, 1)).Interior.ColorIndex = 4
            Case bh
                Range(c, c.Offset(, 1)).Interior.ColorIndex = 5
            Case s
                Range(c, c.Offset(, 1)).Interior.ColorIndex = 4
            Case Else
                iCol = 0
        End Select
Next c

End Sub

also add extra "case" sections where needed

 

[Dave_P_C]

Many thanks to shippey121 for his suggested code.

I have altered my code so that it now works as required.

My code as it stands (now working thanks to shippey121) is below.

Sub SetCellColour()

Dim cell As Range

For Each cell In ActiveSheet.Range("C13:U163")
If cell.Value = "F" Then
cell.Interior.ColorIndex = 8 'Light Blue
Range(cell, cell.Offset(, 1)).Interior.ColorIndex = 8 'Light Blue
ElseIf cell.Value = "SD" Then
cell.Interior.ColorIndex = 7 'Pink
Range(cell, cell.Offset(, 1)).Interior.ColorIndex = 7 'Pink
ElseIf cell.Value = "S" Then
cell.Interior.ColorIndex = 15 'Grey
Range(cell, cell.Offset(, 1)).Interior.ColorIndex = 15 'Grey
ElseIf cell.Value = "BH" Then
cell.Interior.ColorIndex = 6 'Yellow
Range(cell, cell.Offset(, 1)).Interior.ColorIndex = 6 'Yellow
ElseIf cell.Value = "H" Then
cell.Interior.ColorIndex = 4 'Green
Range(cell, cell.Offset(, 1)).Interior.ColorIndex = 4 'Green
ElseIf cell.Value = "" Then
cell.Interior.ColorIndex = 0 'Blank
' cell.Interior.Pattern = xlSolid
' cell.Interior.PatternColorIndex = xlAutomatic
End If
Next

End Sub

 

[shippey121]

DAVE

your code could be simplyfied to

Sub COLOR()
Dim cell As Range

For Each cell In ActiveSheet.Range("C13:U163")
If cell.Value = "F" Then
Range(cell, cell.Offset(, 1)).Interior.ColorIndex = 8 'Light Blue
ElseIf cell.Value = "SD" Then
Range(cell, cell.Offset(, 1)).Interior.ColorIndex = 7 'Pink
ElseIf cell.Value = "S" Then
Range(cell, cell.Offset(, 1)).Interior.ColorIndex = 15 'Grey
ElseIf cell.Value = "BH" Then
Range(cell, cell.Offset(, 1)).Interior.ColorIndex = 6 'Yellow
ElseIf cell.Value = "H" Then
Range(cell, cell.Offset(, 1)).Interior.ColorIndex = 4 'Green
ElseIf cell.Value = "" Then
cell.Interior.ColorIndex = 0 'Blank

End If
Next
End Sub

in your existing code

the line

cell.Interior.ColorIndex = 8 'Light Blue

is changing the cell which was being checked and then on the next line

Range(cell, cell.Offset(, 1)).Interior.ColorIndex = 8 'Light Blue

this is changing both cells, example

if C13 had the letter F, your code would change C13 to light blue then C13:D13 to light blue, remove all the lines starting with cell. and your code will run faster

 

[Dave_P_C]

Many thanks once more Shippey.

Very much appreciated.