Changing Tab Color based on certain cell value using VBA

[sprimax]

Folks,

I have 5 sheets, name 1,2,3,4 and Summary what I want is :
if cell value in B6 (progress) is 0%, then tab color changing to Red
if cell value in B6 (progress) is greater than 0 but less than 100%, tab color change to Green. Else is Black.

That should happen only in sheets 1,2,3,4 but not for Summary.

Is there any code to do that ?

I tried to put the code in ThisWorkbook, and it won't work :
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("B6").Value = 0 Then
ActiveWorkbook.Sheets.Tab.Color = 255
ElseIf Range("B6").Value < 1 Then
ActiveWorkbook.Sheets.Tab.Color = 5287936
ElseIf Range("B6").Value = 1 Then
ActiveWorkbook.Sheets.Tab.Color = 0
Else
ActiveWorkbook.Sheets("test").Tab.ColorIndex = -4142
End If
End Sub

Please help me, thank you

 

[GTO]

Assuming ActiveWorkbook is ThisWorkbook, I didn't quite grasp "test" worksheet if we only have five worksheets. DIsregarding that part for the moment, maybe something like:

In the ThisWorkbook Module:
<font face=Courier New><SPAN style="color:#00007F">Option</SPAN> <SPAN style="color:#00007F">Explicit</SPAN><br>    <br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> Workbook_SheetChange(<SPAN style="color:#00007F">ByVal</SPAN> Sh <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Object</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> Target <SPAN style="color:#00007F">As</SPAN> Range)<br>    <br>    <SPAN style="color:#00007F">If</SPAN> Sh.Name <SPAN style="color:#00007F">Like</SPAN> "[1,2,3,4]" <SPAN style="color:#00007F">Then</SPAN><br>        <SPAN style="color:#00007F">If</SPAN> Target.Count = 1 And <SPAN style="color:#00007F">Not</SPAN> Application.Intersect(Sh.Range("B6"), Target) <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN> <SPAN style="color:#00007F">Then</SPAN><br>            <SPAN style="color:#00007F">Select</SPAN> <SPAN style="color:#00007F">Case</SPAN> Sh.Range("B6").Value<br>            <SPAN style="color:#00007F">Case</SPAN> 0<br>                Sh.Tab.Color = 255<br>            <SPAN style="color:#00007F">Case</SPAN> <SPAN style="color:#00007F">Is</SPAN> < 1<br>                Sh.Tab.Color = 5287936<br>            <SPAN style="color:#00007F">Case</SPAN> 1<br>                Sh.Tab.Color = 0<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Select</SPAN><br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

 

[sprimax]

Dear GTO,

Thanks for the magic code, it works ! But only for 9 sheets, it didn't work for sheets 10 to 20. Right now I have 20 Well Program projects I have to monitor the progress.

Could you tell me what is "Option Explicit" phrase mean in VBA?

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

If Sh.Name Like "[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]" Then
If Target.COUNT = 1 And Not Application.Intersect(Sh.Range("B6"), Target) Is Nothing Then
Select Case Sh.Range("B6").Value
Case 0
Sh.Tab.Color = 255
Case Is < 1
Sh.Tab.Color = 5287936
Case 1
Sh.Tab.Color = 0
End Select
End If
End If
End Sub

regards,

 

[GTO]

Okay, I just goobered that one pretty good. I don't know what I was thinking the commas were going to do. Read vba Help to see what I mean, but basically we would only be matching if the sheet name equals ONE of the characters between the brackets.

We can still use Like to see if the sheetname is comprised of two digits, and limit it after that. (presuming I'm not still in a coma)

Try:

Option Explicit
    
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    
    If Sh.Name Like "##" Then
        If CLng(Sh.Name) < 21 Then
            If Target.Count = 1 And Not Application.Intersect(Sh.Range("B6"), Target) Is Nothing Then
                Select Case Sh.Range("B6").Value
                Case 0
                    Sh.Tab.Color = 255
                Case Is < 1
                    Sh.Tab.Color = 5287936
                Case 1
                    Sh.Tab.Color = 0
                End Select
            End If
        End If
    End If
End Sub

Option Explicit included at the top of the module insists that you declare all variables. This saves you headaches later, as it will catch mis-spelt variables...

 

[sprimax]

Dear GTO,

Thanks so much ! I really appreciate it !
This is wonderful !

Cool mrexcel.com solution forum ever !

 

[sprimax]

Dear GTO,

I saved the file, exit and when I reopen the file, the code right now only working for all sheets with one digit.

I've tried to change :

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

If Sh.Name Like "##" And "#" Then
If CLng(Sh.Name) < 21 Then
If Target.COUNT = 1 And Not Application.Intersect(Sh.Range("M6"), Target) Is Nothing Then
Select Case Sh.Range("M6").Value
Case 0
Sh.Tab.Color = 255
Case Is < 1
Sh.Tab.Color = 5287936
Case 1
Sh.Tab.Color = 0
End Select
End If
End If
End If
End Sub

But it won't work.

Thanks

 

[sprimax]

This is the code (that not work)

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

If Sh.Name Like "##" Then
If CLng(Sh.Name) < 21 Then
If Target.COUNT = 1 And Not Application.Intersect(Sh.Range("B6"), Target) Is Nothing Then
Select Case Sh.Range("B6").Value
Case 0
Sh.Tab.Color = 255
Case Is < 1
Sh.Tab.Color = 5287936
Case 1
Sh.Tab.Color = 0
End Select
End If
End If
End If
End Sub

 

[GTO]

If Target.COUNT...

Why is COUNT in UCase? Are you copying the code directly as you have it in the module?

Also, do you have the code plunked into ThisWorkbook module?

 

[sprimax]

I copy it exactly from you, but when I paste into ThisWorkbook module (Lcase), it turns automatically into Ucase.

If Target.COUNT

I use MS Office 2007

Thanks

 

[GTO]

Try the code at #4 in a new instance and new wb. I do not see a reason for it not to work.