The music keeps rolling on

[Lawrence Dodge]

Hi all --
I have a spread sheet with individual's id number on the left column and test scores (if available) under each month. I would like to automatically color the cells if 3, 4, 5, etc. cells have a value entered in a row. (see attached)
I have played a little with the information given on the rolling average blog page, but got nowhere. Any thoughts?
thanks
Lawrence

 

[Luke M]

Do you need to have the gradient color scale, or would 3 colors be sufficient? If the latter, we could do something with the CF to get the colors. If the former...I think we'd have to use VB to color the cells correctly.

 

[Lawrence Dodge]

Hi Luke --
No, we could do something like 3 in a row green, 4 in a row yellow, 5 or more red; that would be cool.
LCD

 

[SirJB7]

Hi, Lawrence Dodge!

Give a look at the attached file. It has 2 versions.

1st worksheet uses only CF formulas, 6 rules set with this formula:
=Y(ESNUMERO(B3);CONTAR($B3:$I3)<operator><value>) -----> in english: =AND(ISNUMBER(B3),COUNT($B3:$I3)<operator><value>)

2nd worksheet uses VBA for trapping the worksheet change event and has 2 dynamic named ranges:
DataTable: =DESREF('Sheet1 VBA'!$B$3;;;CONTARA('Sheet1 VBA'!$A:$A);CONTARA('Sheet1 VBA'!$1:$1)-1) -----> in english: =OFFSET('Sheet1 VBA'!$B$3,,,COUNTA('Sheet1 VBA'!$A:$A),COUNTA('Sheet1 VBA'!$1:$1)-1)
ColorTable: =DESREF('Sheet1 VBA'!$J$1;;;CONTARA('Sheet1 VBA'!$J:$J);2) -----> in english: =OFFSET('Sheet1 VBA'!$J$1,,,COUNTA('Sheet1 VBA'!$J:$J),2)

This is the code:

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    ' constants
    Const ksData = "DataTable"
    Const ksColor = "ColorTable"
    ' declarations
    Dim rngD As Range, rngC As Range, rngI As Range, rngF As Range
    Dim I As Long, J As Integer, K As Integer
    ' start
    Application.ScreenUpdating = False
    Set rngD = Range(ksData)
    Set rngI = Application.Intersect(rngD, Target)
    If rngI Is Nothing Then GoTo Worksheet_Change_Exit
    With rngD
        I = rngI.Row - .Row + 1
        Set rngI = Range(.Rows(I), .Rows(I + rngI.Rows.Count - 1))
    End With
    Set rngC = Range(ksColor)
    ' process
    With rngI
        For I = 1 To .Rows.Count
            J = Application.WorksheetFunction.Count(.Rows(I))
            Set rngF = rngC.Columns(1).Find(J)
            If Not rngF Is Nothing Then
                J = rngF.Row
                For K = 1 To .Columns.Count
                    If Val(.Cells(I, K).Value) > 0 Then
                        .Cells(I, K).Interior.Color = rngC.Cells(J, 2).Interior.Color
                    End If
                Next K
            End If
        Next I
    End With
    ' end
    Set rngF = Nothing
    Set rngC = Nothing
    Set rngI = Nothing
Worksheet_Change_Exit:
    Set rngD = Nothing
    Application.ScreenUpdating = True
End Sub

Just advise if any issue.

Regards!