Change Tab Color based on dynamic cell value

[crazi4sports10]

I need to change the tab color based on the value found under the words "inception difference" in that tab. The tabs have between 1-10 numbers below "inception difference." If all numbers below "inception difference" are negative, make the tab red. If they are all positive, make the tab green. If some are negative and some are positive, make the tab yellow.

 

[tonyyy]

You might try something like...

Sub TabColor()

Dim sht As Worksheet
Dim i As Long
Dim LastRow As Long
Dim r As Range

For i = 1 To ThisWorkbook.Worksheets.Count
    Worksheets(i).Activate
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Set r = Range("A2:A" & LastRow)
    If Application.CountIf(r, "<0") = LastRow - 1 Then
        With ActiveWorkbook.Sheets(i).Tab
        .Color = 255
        End With
        
        Else
            If Application.CountIf(r, ">0") = LastRow - 1 Then
                With ActiveWorkbook.Sheets(i).Tab
                .Color = 5287936
                End With
            Else
                With ActiveWorkbook.Sheets(i).Tab
                .Color = 65535
                End With
            End If
    End If
Next i

End Sub

This code assumes "inception difference" is in cell A1; adjust accordingly.

Cheers,

tonyyy

 

[crazi4sports10]

Appreciate the help, but the challenge is that "inception difference" is in a different cell in every tab. I'm hoping the macro finds "inception difference" and goes from there

You might try something like...

Sub TabColor()

Dim sht As Worksheet
Dim i As Long
Dim LastRow As Long
Dim r As Range

For i = 1 To ThisWorkbook.Worksheets.Count
    Worksheets(i).Activate
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Set r = Range("A2:A" & LastRow)
    If Application.CountIf(r, "<0") = LastRow - 1 Then
        With ActiveWorkbook.Sheets(i).Tab
        .Color = 255
        End With
        
        Else
            If Application.CountIf(r, ">0") = LastRow - 1 Then
                With ActiveWorkbook.Sheets(i).Tab
                .Color = 5287936
                End With
            Else
                With ActiveWorkbook.Sheets(i).Tab
                .Color = 65535
                End With
            End If
    End If
Next i

End Sub

This code assumes "inception difference" is in cell A1; adjust accordingly.

Cheers,

tonyyy

 

[tonyyy]

Is "inception difference" in the first row of the sheet? Or can it really be anywhere?

 

[tonyyy]

Okay, this code finds "inception difference" and goes from there...

Sub InceptionDifference()

Dim LastRow As Long
Dim LastColumn As Integer
Dim id As Range
Dim sht As Worksheet
Dim i As Long
Dim r As Range

For i = 1 To ThisWorkbook.Worksheets.Count
    Worksheets(i).Activate
    
    If WorksheetFunction.CountA(Cells) > 0 Then
        LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        LastColumn = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    
    Set r = Range(Cells(1, 1), Cells(LastRow, LastColumn))
    Set id = r.Find(What:="inception difference", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
        
    Dim idLastRow As Long
    Dim r2 As Range
    If id.Value <> "" Then idLastRow = Cells(Rows.Count, id.Column).End(xlUp).Row

    Set r2 = Range(id.Address, Cells(idLastRow, id.Column))

        If Application.CountIf(r2, "<0") = idLastRow - id.Row Then
            With ActiveWorkbook.Sheets(i).Tab
            .Color = 255
            End With
    
        Else
            If Application.CountIf(r2, ">0") = idLastRow - id.Row Then
                With ActiveWorkbook.Sheets(i).Tab
                .Color = 5287936
                End With
            Else
                With ActiveWorkbook.Sheets(i).Tab
                .Color = 65535
                End With
            End If
        End If
    End If
Next i
    
End Sub

Cheers,

tonyyy

 

[crazi4sports10]

VBA highlights If id.Value <> "" Then as a source of error in the code. I should also add there are some tabs that don't have "inception difference" - leave those tabs white. Any other ideas? I feel like we're close.

Okay, this code finds "inception difference" and goes from there...

Sub InceptionDifference()

Dim LastRow As Long
Dim LastColumn As Integer
Dim id As Range
Dim sht As Worksheet
Dim i As Long
Dim r As Range

For i = 1 To ThisWorkbook.Worksheets.Count
    Worksheets(i).Activate
    
    If WorksheetFunction.CountA(Cells) > 0 Then
        LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        LastColumn = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    
    Set r = Range(Cells(1, 1), Cells(LastRow, LastColumn))
    Set id = r.Find(What:="inception difference", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
        
    Dim idLastRow As Long
    Dim r2 As Range
    If id.Value <> "" Then idLastRow = Cells(Rows.Count, id.Column).End(xlUp).Row

    Set r2 = Range(id.Address, Cells(idLastRow, id.Column))

        If Application.CountIf(r2, "<0") = idLastRow - id.Row Then
            With ActiveWorkbook.Sheets(i).Tab
            .Color = 255
            End With
    
        Else
            If Application.CountIf(r2, ">0") = idLastRow - id.Row Then
                With ActiveWorkbook.Sheets(i).Tab
                .Color = 5287936
                End With
            Else
                With ActiveWorkbook.Sheets(i).Tab
                .Color = 65535
                End With
            End If
        End If
    End If
Next i
    
End Sub

Cheers,

tonyyy

 

[tonyyy]

It would help to get a little more info...

Did the macro run at all? Did it color some of the tabs correctly? Incorrectly?
On what sheet did the error occur? Was it a sheet with "inception difference" or without?
Is there an error number and/or an error description?

And there was a question earlier in the thread: "Is "inception difference" in the first row of the sheet? Or can it really be anywhere?"

 

[crazi4sports10]

Sorry, I should've been more clear and greatly appreciate your help. Last night, the Macro wouldn't even run when I started on the first tab, which does NOT contain "inception difference". This morning, the Macro ran over all tabs, but colored them ALL yellow. I have since run it a couple of times and it runs all the way through (without an error message), but colors them all yellow. "Inception Difference" is never in a consistent row, but is always in Column I, IF it even exists on the sheet. Please let me know how else I can help

 

[tonyyy]

Thanks for the info. A few more questions please...

In your original post you stated, "The tabs have between 1-10 numbers below "inception difference." Are the cells with numbers contiguous? Or are there sometimes blank cells separating them? (And are they blank cells or zero value cells?) Are the 10 cells immediately below "inception difference" reserved for inception difference values? Below the maximum 10 numbers, are there other cells in Column I that contain values?

 

[crazi4sports10]

Great questions. Just to be safe, the max number of cells below "inception difference" that might contain a value is 25, but it could just be 2 (see formula below). Once there is a value under "inception difference", there will be consecutive numbers (assuming there is more than 1 numbered cell) until you hit a blank - there will never be a value and then a blank and then another value. The cell after all the numbers below "inception difference" (somewhere between 1-20 of them) is blank, not zero. Rows below "inception difference" = N+1, where N is the number of values you have (somewhere between 1-25). After N+1, you hit a blank merged cell and possibly some text cells, but there are no numbers anywhere in column I after the last value under "inception difference"