Counting conditional formatting cells by colorIndex

问题:

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 

回答1:

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.

回答2:

• 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):

回答3:

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.

文章来源: Counting conditional formatting cells by colorIndex