Counting conditional formatting cells by colorIndex

Question

I have some people, whose working time are shown by the conditional formatting in the cells on their own columns - e.g. B7:B36, C7:C36, D7:D36 and so. I try to count the conditional formatting cells to the column E. The end result in the cell is #Value (Arvo), but when you press F9, then the numbers can be displayed.

When I run the code step by step, I noticed that after the line "Range("B6", ws.Cells.SpecialCells(xlCellTypeLastCell)).ClearFormats program jump to function "Function CountRed(MyRange As Range" and stay in the Loop for some time.

Is this because that there is a function "CountRed(B6)+CountGreen(C6)+CountBlue(D6)" for example in the cell E6?

In addition, I would like the column numbers in column E are concentrated in the central.

Error if exit time is empty:

Result with error in col E:

Results should look like this:

The original code can be also found here - Thanks Floris!

Option Explicit
Private Sub worksheet_change(ByVal target As Range)

If Not Intersect(target, Range("B4:Q4")) Is Nothing Then

 'Sub makeTimeGraph()
    Dim startRow As Long
    Dim endRow As Long
    Dim entryTimeRow As Long
    Dim entryTimeFirstCol As Long
    Dim Applicaton
    Dim ws As Excel.Worksheet
    Dim timeRange As Range
    Dim c
    Dim timeCols As Range
    Dim entryTime
    Dim exitTime
    Dim formatRange As Excel.Range
    Dim eps
    eps = 0.000001 ' a very small number - to take care of rounding errors in lookup
    Dim entryName
    Dim Jim
    Dim Mark
    Dim Lisa
    Dim nameCols As Range

    ' change these lines to match the layout of the spreadsheet
    ' first cell of time entries is B4 in this case:
    entryTimeRow = 4
    entryTimeFirstCol = 2
    ' time slots are in column A, starting in cell A6:
    Set timeRange = Range("A6", [A6].End(xlDown))

    ' columns in which times were entered:
    Set ws = ActiveSheet
    Set timeCols = Range("B4:Q4") ' select all the columns you want here, but only one row
    Set nameCols = Range("B3:Q3") ' columns where the names are in the third row

    ' clear previous formatting
    Range("B6", ws.Cells.SpecialCells(xlCellTypeLastCell)).ClearFormats

    Application.ScreenUpdating = False

    ' loop over each of the columns:
    For Each c In timeCols.Cells

      Application.StatusBar = entryName
      If IsEmpty(c) Then GoTo nextColumn

      entryTime = c.Value
      exitTime = c.Offset(1, 0).Value
      entryName = c.Offset(-1, 0).Value

      startRow = Application.WorksheetFunction.Match(entryTime + eps, timeRange) + timeRange.Cells(1.1).Row - 1
      endRow = Application.WorksheetFunction.Match(exitTime - eps, timeRange) + timeRange.Cells(1.1).Row - 1
      Set formatRange = Range(ws.Cells(startRow, c.Column), ws.Cells(endRow, c.Column))

      'select format range
      formatRange.Select


      ' select name for coloring
      Select Case entryName

        Case "Jim"
            Call formatTheRange1(formatRange)    ' Red  Colorinex 3

        Case "Mark"
            Call formatTheRange2(formatRange)   ' Green Colorindex 4

        Case "Lisa"
            Call formatTheRange3(formatRange)    ' Blue Colorindex 5

    End Select

nextColumn:
    Next c
End If
Range("A1").Activate
Application.ScreenUpdating = True

End Sub

Private Sub formatTheRange1(ByRef r As Excel.Range)

       r.HorizontalAlignment = xlCenter
       r.Merge

          ' Apply color red coloroindex 3
          With r.Interior
             .Pattern = xlSolid
             .ColorIndex = 3
             '.TintAndShade = 0.8
             Selection.UnMerge
         End With

End Sub

Private Sub formatTheRange2(ByRef r As Excel.Range)

         r.HorizontalAlignment = xlCenter
         r.Merge

          ' Apply color  Green Colorindex 4
          With r.Interior

             .Pattern = xlSolid
             .ColorIndex = 4
             '.TintAndShade = 0.8
                 Selection.UnMerge
         End With

End Sub

Private Sub formatTheRange3(ByRef r As Excel.Range)

         r.HorizontalAlignment = xlCenter
         r.Merge

          ' Apply color  Blue Colorindex 5
          With r.Interior

             .Pattern = xlSolid
             .ColorIndex = 5
           '.TintAndShade = 0.8
               Selection.UnMerge
         End With

End Sub

Function CountRed(MyRange As Range)
    Dim i As Integer
    Application.Volatile
    i = 0
    For Each cell In MyRange
        If cell.Interior.ColorIndex = 3 Then
            i = i + 1
        End If
    Next cell
    CountRed = i
End Function

Function CountGreen(MyRange As Range)
    Dim i As Integer
    Application.Volatile
    i = 0
    For Each cell In MyRange
        If cell.Interior.ColorIndex = 4 Then
            i = iCount + 1
        End If
    Next cell
    CountGreen = i
End Function

Function CountBlue(MyRange As Range)
    Dim i As Integer
    Application.Volatile
    i = 0
    For Each cell In MyRange
        If cell.Interior.ColorIndex = 5 Then
            i = i + 1
        End If
    Next cell
    CountBlue = i
End Function

Answer 1

I am not a fan of writing macro, unless you exhausted the capabilities of Excel. Instead of attacking the problem through the ColorIndex, go back to the source of your data. Use this formula on E6

{=SUM(($B$4:$D$4<=A6)*($B$5:$D$5>A6))}

Remember to use Ctrl+Shift+Enter to enable the array function, instead of just Enter. Paste down and it will perform the behavior you are aiming for.

Answer 2

Hyvää päivää! It's me again… Good to see you are continuing to improve your code. I have made a few tweaks to make it work a bit better. In particular:

• Modified the test of the Target - so it will update both when you change the start time, and when you change the end time. You were only doing things when the start time was changed.
• Just one formatting function instead of 3, with a second parameter (color). This keeps the code a little tidier. You could even have a dictionary of key/value pairs - but that doesn't work on a Mac which is where I'm writing this so I won't show you.
• Hidden inside the colored cell is the number 1, with the same color as the background (hence "invisible") - this is added by the formatting function
• Now your "sum" column can just contain a SUM(B6:D6) style formula that you copy down the column. This is considerably faster than three custom functions that check for the color in the cells to their left… (removed those functions from the code)
• Have to clear the entire column's values (not just formatting) to remove any 1s left over from a previous run; this is done in the per-column loop (rather than all at once) to preserve the SUM() formulas in the "per day" columns.
• Nothing is ever selected by the code - so there's nothing to unselect at the end; this means that the selection doesn't jump to the A1 cell every time you make an edit.
• Removed the Dim Jim etc statements since you did not use those variables.

Now that the code is modifying the sheet (changing the values in cells by adding the invisible ones) there is a risk of things really slowing down (every change causes the event to fire again) - so I am turning off the events when you enter the function, and turn them on again when you leave (using Application.EnableEvents = False or True respectively); to be safe, errors are also trapped (with On Error GoTo whoops) - these send your code straight to the "enable events and exit function" part of the code.

Presumably you have figured out that this code needs to live in the worksheet code (rather than a regular module) in order to receive the events properly.

Here is the new code:

Option Explicit
Private Sub worksheet_change(ByVal target As Range)

On Error GoTo whoops

If Not Intersect(target, Range("B4:Q5")) Is Nothing Then

    Dim startRow As Long
    Dim endRow As Long
    Dim entryTimeRow As Long
    Dim entryTimeFirstCol As Long
    Dim Applicaton
    Dim ws As Excel.Worksheet
    Dim timeRange As Range
    Dim c
    Dim timeCols As Range
    Dim entryTime
    Dim exitTime
    Dim formatRange As Excel.Range
    Dim eps
    eps = 1e-06    ' a very small number - to take care of rounding errors in lookup
    Dim entryName
    Dim nameCols As Range

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    ' change these lines to match the layout of the spreadsheet
    ' first cell of time entries is B4 in this case:
    entryTimeRow = 4
    entryTimeFirstCol = 2
    ' time slots are in column A, starting in cell A6:
    Set timeRange = Range("A6", [A6].End(xlDown))

    ' columns in which times were entered:
    Set ws = ActiveSheet
    Set timeCols = Range("B4:Q4") ' select all the columns you want here, but only one row
    Set nameCols = Range("B3:Q3") ' columns where the names are in the third row

    ' clear previous values and formatting
    Range("B6", ws.Cells.SpecialCells(xlCellTypeLastCell)).clearFormats

    ' loop over each of the columns:
    For Each c In timeCols.Cells

      'Application.StatusBar = entryName
      If IsEmpty(c) Then GoTo nextColumn

      entryTime = c.Value
      exitTime = c.Offset(1, 0).Value
      entryName = c.Offset(-1, 0).Value

      startRow = Application.WorksheetFunction.Match(entryTime + eps, timeRange) + timeRange.Cells(1.1).Row - 1
      endRow = Application.WorksheetFunction.Match(exitTime - eps, timeRange) + timeRange.Cells(1.1).Row - 1

      ' get rid of any values currently in this row:
      timeRange.Offset(0, c.Column - 1).Clear

      Set formatRange = Range(ws.Cells(startRow, c.Column), ws.Cells(endRow, c.Column))

      ' select name for coloring
      Select Case entryName

        Case "Jim"
            Call formatTheRange(formatRange, 3)   ' Red  Colorindex 3
        Case "Mark"
            Call formatTheRange(formatRange, 4)   ' Green Colorindex 4
        Case "Lisa"
            Call formatTheRange(formatRange, 5)   ' Blue Colorindex 5

    End Select

nextColumn:
    Next c

End If

whoops:
If Err.Number > 0 Then
  MsgBox "error: " & Err.Description
  Err.Clear
End If

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Private Sub formatTheRange(ByRef r As Excel.Range, c)

  Dim cc

  ' Apply color c
  With r.Interior
    .Pattern = xlSolid
    .ColorIndex = c
  End With

  r.Font.ColorIndex = c

  ' put an invisible 1 in each cell:
  For Each cc In r.Cells
    cc.Value = 1
  Next

End Sub

Here's how things look (just one set of columns showing - but this should work fine in your multi-column version):

Answer 3

The #VALUE!(ARVO) error could be overcome by adding ws.Calculate to the end of your Private Sub worksheet_change(ByVal target As Range) procedure.

That said, your desired outcomes:

• Graphic representation of time being worked by employees
• How many people are working during different time intervals

Can be accomplished using conditional formatting in columns B:D and COUNTIFS functions in column E.

To set up the conditional format in column B:

1. Select from B6 down to the cell adjacent to the last time in column A
2. Click Conditional Formatting and click on the "Use a formula..." option
3. Enter =AND(A6>=B$4,$A6<B$5) in the formula box
4. Click the Format.. button and select Fill colour
5. Click OK
6. Click Apply or OK to see the result or close the dialogue

You can copy the conditional formats to columns C and D then edit their fill colours as desired.

In cell E6 inter the formula:

=COUNTIFS(A6,">="&B$4,A6,"<"&B$5)
+COUNTIFS(A6,">="&C$4,A6,"<"&C$5)
+COUNTIFS(A6,">="&D$4,A6,"<"&D$5)

Copy from B6 down to E last time row into F6; J6 etc.

By not using VBA at all you will improve worksheet performance. It's usually better to use Excel functionality and built-in functions where possible and reserve VBA to do repetitive tasks and create UDFs to calculate thing that can't be done using built-in functions.