PDA

View Full Version : Solved: Worksheet Function Change Row Colors According to Value



rama4672
05-19-2004, 11:20 AM
I have done a service schedule in Excel, What i am trying to get it to do is when you put an "x" in a cell it will automatically change the color of the cell.
Below is the code i have written, Can someone throw some light on what i am doing wrong(probaly everything)
Thanks
Ian


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim x As Integer
Dim s As Integer
Dim m As Integer
With Range("A1:z150")
If Cells.Value = x Then
Cells.Interior.ColorIndex = 34
If Cells.Value = s Then
Cells.Interior.ColorIndex = 32
End If
End If
End With
End Sub

Zack Barresse
05-19-2004, 11:42 AM
hello Ian!

what are x, s, and m values? or do you mean the characters "x", "s" & "m"?

and will there be more than only those?

rama4672
05-19-2004, 12:52 PM
thanks for the reply Zack
yes they are the characters, there will be probabley 5 characters altogether, ie: m will stand for mot, s for service and so on.

Zack Barresse
05-19-2004, 01:28 PM
hello Ian, sorry about the delay, got busy suddenly. try this in your worksheet code...

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column > 26 Or Target.Row > 150 Then Exit Sub
On Error GoTo err1
Select Case Target.Value
Case Is = "x"
Target.Interior.ColorIndex = 34
Case Is = "s"
Target.Interior.ColorIndex = 32
Case Is = "m"
Target.Interior.ColorIndex = 55
Case Is = ""
Target.Interior.ColorIndex = 0
err1: Exit Sub
End Select

End Sub


substitute for your desired changes, and add as needed.

does this help?

rama4672
05-19-2004, 10:42 PM
Thanks Zack

Just what i needed

Ian

Anne Troy
05-19-2004, 10:53 PM
Hi, guys!!

Ian: Welcome to the board!

Is this some code we should push to the knowledgebase?
Is it something others might be able to use sometime, and can we have your permission to post it up there, Ian?

What do you think?

Please notice the new ranking icons for people with knowledgebase contributions. :)

SJ McAbney
05-20-2004, 01:34 AM
Is there somewhere that lists what all the different colours and/or quantities mean with respect to contributions?

rama4672
05-20-2004, 04:08 AM
Hi Anne

Yes i think it could be useful to others
Here is a bit of code i found that lists all the colors with their respective numbers


Sub colors56()
'57 colors, 0 to 56
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
Dim i As Long
Dim str0 As String, str As String
For i = 0 To 56
Cells(i + 1, 1).Interior.colorindex = i
Cells(i + 1, 1).Value = "[Color " & i & "]"
Cells(i + 1, 2).Font.colorindex = i
Cells(i + 1, 2).Value = "[Color " & i & "]"
str0 = Right("000000" & Hex(Cells(i + 1, 1).Interior.color), 6)
'Excel shows nibbles in reverse order so make it as RGB
str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
'generating 2 columns in the HTML table
Cells(i + 1, 3) = "#" & str & "#" & str & ""
Cells(i + 1, 4).Formula = "=Hex2dec(""" & Right(str0, 2) & """)"
Cells(i + 1, 5).Formula = "=Hex2dec(""" & Mid(str0, 3, 2) & """)"
Cells(i + 1, 6).Formula = "=Hex2dec(""" & Left(str0, 2) & """)"
Cells(i + 1, 7) = "[Color " & i & ")"
Next i
done:
Application.Calculation = xlCalculationAutomatic 'pre XL97 xlAutomatic
Application.ScreenUpdating = True
End Sub



Regards
Ian

Anne Troy
05-20-2004, 06:29 AM
Hi, Abulafia: Not yet. I need to create a page. :)

Ian: Thanks! Can you make a sample file with that in it?

rama4672
05-22-2004, 12:40 PM
Sorry it took so long to get back to you I just got side tracked on something else, But here is my demo file showing everything is working as it should

Regards

Ian

Anne Troy
05-22-2004, 12:44 PM
Not a problem, Ian!

I'm waiting for our submission form anyway, now.
No sense in building manually what can be automated, right?

:)

Ivan F Moala
05-22-2004, 03:23 PM
Hi Anne

Yes i think it could be useful to others
Here is a bit of code i found that lists all the colors with their respective numbers


Sub colors56()
'57 colors, 0 to 56
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
Dim i As Long
Dim str0 As String, str As String
For i = 0 To 56
Cells(i + 1, 1).Interior.colorindex = i
Cells(i + 1, 1).Value = "[Color " & i & "]"
Cells(i + 1, 2).Font.colorindex = i
Cells(i + 1, 2).Value = "[Color " & i & "]"
str0 = Right("000000" & Hex(Cells(i + 1, 1).Interior.color), 6)
'Excel shows nibbles in reverse order so make it as RGB
str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
'generating 2 columns in the HTML table
Cells(i + 1, 3) = "#" & str & "#" & str & ""
Cells(i + 1, 4).Formula = "=Hex2dec(""" & Right(str0, 2) & """)"
Cells(i + 1, 5).Formula = "=Hex2dec(""" & Mid(str0, 3, 2) & """)"
Cells(i + 1, 6).Formula = "=Hex2dec(""" & Left(str0, 2) & """)"
Cells(i + 1, 7) = "[Color " & i & ")"
Next i
done:
Application.Calculation = xlCalculationAutomatic 'pre XL97 xlAutomatic
Application.ScreenUpdating = True
End Sub



Regards
Ian
Ian just a couple of things
1) that code requires the AnalysisTool pac VBA installed in order to be run.
2) There are only 56 colors your indexing starts @ 0 - 56 = 57
3) The Hex values don't look right? or rather they have doubled


here is an alternative with no ATP required.




Sub GetRGB_ColorIndex()
'// Ivan F Moala
'// http://www.xcelfiles.com

Dim k, x As Single

'// 1st Clear Old data
Range([A1:G1], [A1:G1].End(xlDown)).ClearContents
x = 1
Frmt
Application.ScreenUpdating = False

[A1] = "ColorIndex"
[B1] = "Color"
[C1] = "LongValue"
[D1] = "RED"
[E1] = "GREEN"
[F1] = "BLUE"
[G1] = "HEX"

For Each k In ActiveWorkbook.Colors
Cells(x + 1, 1) = x 'ColorIndex
Cells(x + 1, 2).Interior.ColorIndex = x 'Color
Cells(x + 1, 3) = k 'Longvalue
Cells(x + 1, 4) = Cells(x + 1, 3).Value And &HFF 'RED
Cells(x + 1, 5) = (Cells(x + 1, 3).Value And &H100FF00) / &H100 'GREEN
Cells(x + 1, 6) = (Cells(x + 1, 3).Value And &HFF0000) / &H10000 'BLUE
Cells(x + 1, 7) = Hex((Cells(x + 1, 3).Value)) 'HEX
x = x + 1
Next k


Columns("A:G").Columns.AutoFit
Application.ScreenUpdating = True

End Sub
Sub Frmt()
With Range("A1:H58")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Columns.AutoFit
.AutoFormat Format:=xlRangeAutoFormat3DEffects2, Number:=False, _
Font:=False, Alignment:=False, Border:=True, Pattern:=True, Width:= _
False
End With

With Range("D1")
.Interior.ColorIndex = 3
.Font.ColorIndex = 2
End With

With Range("F1")
.Interior.ColorIndex = 5
.Font.ColorIndex = 2
End With

Range("E1").Interior.ColorIndex = 4
Range("G1").Interior.ColorIndex = 36
Range("A1:G1").Font.Bold = True

End Sub

rama4672
05-22-2004, 05:00 PM
Thanks for that ivan
Thats probably why it works on one machine which i have the tools pak installed but not on the other

Regards

Ian

jacksonworld
07-28-2005, 06:16 PM
Hi, I was wondering if the following code can be altered a little so as to highlight the entire row, and not just the just the first cell in the column.


[QUOTE=firefytr]

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column > 26 Or Target.Row > 150 Then Exit Sub
On Error GoTo err1
Select Case Target.Value
Case Is = "x"
Target.Interior.ColorIndex = 34
Case Is = "s"
Target.Interior.ColorIndex = 32
Case Is = "m"
Target.Interior.ColorIndex = 55
Case Is = ""
Target.Interior.ColorIndex = 0
err1: Exit Sub
End Select

End Sub


QUOTE]

I was also wanted to use the 4th column as a my target column, rather than the first. Can anyone help me?

Thanks

xld
07-29-2005, 03:50 AM
Hi, I was wondering if the following code can be altered a little so as to highlight the entire row, and not just the just the first cell in the column.

I was also wanted to use the 4th column as a my target column, rather than the first. Can anyone help me?


Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo ws_exit:
Application.EnableEvents = False
With Target
If .Column = 4 Then
Select Case .Value
Case Is = "x"
.EntireRow.Interior.ColorIndex = 34
Case Is = "s"
.EntireRow.Interior.ColorIndex = 32
Case Is = "m"
.EntireRow.Interior.ColorIndex = 55
Case Is = ""
.EntireRow.Interior.ColorIndex = 0
End Select
End If
End With

ws_exit:
Application.EnableEvents = True

End Sub

jacksonworld
07-29-2005, 05:30 PM
Perfect. Thanks for your help. Much appreciated :bow: