Ozgrid Excel Help & Best Practices Forums

Excel Training / Excel Dashboards Reports

# Thread: Subtotal By Cell Color

1. Member
Join Date
6th January 2006
Posts
20
Usergroup
Registered Users

## Subtotal By Cell Color

Count Sum By Color. I have an enormous sheet of 6000+ records. I have a macro running that permits automatic counting of cells according to their background colour. What I would like to be able to do when selecting some records is for the colour count to recognize this, and not continue to count the hidden data. Subtotal works fine regarding the displayed records, but can it be used in conjunction with the colorfunction macro so as to only count the selected record colours where applicable. I would also like to be able to sort according to the background colour, but without adding another column. Are there any boffins out there who can help???????? Please, coz it's driving me nuts!!

VB:
```
Function ColorFunction(rColor As Range, rRange As Range, Optional SUM As Boolean)
Dim rCell As Range
Dim lCol As Long
Dim vResult

lCol = rColor.Interior.ColorIndex

If SUM = True Then
For Each rCell In rRange
If rCell.Interior.ColorIndex = lCol Then
vResult = WorksheetFunction.SUM(rCell, vResult)
End If
Next rCell
Else
For Each rCell In rRange
If rCell.Interior.ColorIndex = lCol Then
vResult = 1 + vResult
End If
Next rCell
End If

ColorFunction = vResult
End Function

```
Cell formula =colorfunction(\$H\$10,\$A:\$A,FALSE) - counts colours
=subtotal(3,B12:B6000)
Last edited by Dave Hawley; December 3rd, 2006 at 11:44. Reason: add code tags, please use when posting codes

Excel Video Tutorials / Excel Dashboards Reports

2. ## Re: Subtotalling cell colours

This is an example of where you are getting the VBA to do much IMO, whereas you can make Excel do the work for you.

My approach is to have a simple Custom Function like the ColorIndex function that is passed a range, and which passes back an array of colorindex numbers. This array can then be passed to the SUMPRODUCT function to do the counting for you. This flexibility allows counting, summing or whatever, as you will see.

My function is

VB:
``` '---------------------------------------------------------------------
Function ColorIndex(rng As Range, _
Optional text As Boolean = False) As Variant
'---------------------------------------------------------------------
Dim cell As Range, row As Range
Dim i As Long, j As Long
Dim iWhite As Long, iBlack As Long
Dim aryColours As Variant

If rng.Areas.Count > 1 Then
ColorIndex = CVErr(xlErrValue)
Exit Function
End If

If rng.Cells.Count = 1 Then
If text Then
aryColours = rng.Font.ColorIndex
Else
aryColours = rng.Interior.ColorIndex
End If
Else
aryColours = rng.Value
i = 0
For Each row In rng.Rows
i = i + 1
j = 0
For Each cell In row.Cells
j = j + 1
If text Then
aryColours(i, j) = cell.Font.ColorIndex
Else
aryColours(i, j) = cell.Interior.ColorIndex
End If
Next cell
Next row
End If

ColorIndex = aryColours

End Function

```
and I would use it in a worksheet like so

VB:
```=SUMPRODUCT(--(ColorIndex(A1:A20)=3)

```
or

VB:
```=SUMPRODUCT(--(ColorIndex(A1:A20)=ColorIndex(A1))

```

VB:
```=SUMPRODUCT((SUBTOTAL(3,OFFSET(A1,ROW(A1:A20)-MIN(ROW(A1:A20)),,1))),--((ColorIndex(A1:A20)=3)))

```
which counts all cells that are red, but are not hidden.
Last edited by Dave Hawley; December 3rd, 2006 at 11:45.

3. Member
Join Date
6th January 2006
Posts
20
Usergroup
Registered Users

## Re: Subtotalling cell colours

Thanks Bob, will give it a go tomorrow.

Steve

Excel Video Tutorials / Excel Dashboards Reports

4. ## Re: Subtotalling cell colours

Let us know how it goes.

5. Member
Join Date
6th January 2006
Posts
20
Usergroup
Registered Users

## Re: Subtotalling cell colors

Bob,

Thanks very much, code worked a treat, but have a couple more questions.

1. I use the code ### =SUM(IF(B12:B5989="ej7",IF(LEFT(J12:J5989,3)="4GS",1,0))) #### to sum values that begin in this case with "4GS" and =ej7. As with the previous request I would also like to subtotal these values to count only the the filtered records.
2. In addition to this I would also like to select the cell next to the one displaying the count values (Displays the count identifier) and perform a sort. I have been trying to use this..........

VB:
```Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
'GoTo bottom
If cell = ("\$C\$16") Then Goto Line5
If cell = ("\$D\$16") Then Goto Line10
If cell = ("\$E\$16") Then Goto Line15
If cell = ("\$F\$16") Then Goto Line20
If cell = ("\$G\$16") Then Goto Line25
If cell = ("\$H\$16") Then Goto Line30
If cell = ("\$I\$16") Then Goto Line35
If cell = ("\$J\$16") Then Goto Line40
If cell = ("\$K\$16") Then Goto Line45
If cell = ("\$L\$16") Then Goto Line50
If cell = ("\$M\$16") Then Goto Line55
If cell = ("\$N\$16") Then Goto Line60
If cell = ("\$O\$16") Then Goto Line65
If cell = ("\$P\$16") Then Goto Line70
If cell = ("\$C\$7") Then Goto Line75
If cell = ("\$D\$7") Then Goto Line80
If cell = ("\$E\$7") Then Goto Line85
If cell = ("\$F\$7") Then Goto Line90
If cell = ("\$G\$7") Then Goto Line95
If cell = ("\$H\$7") Then Goto Line100
If cell = ("\$I\$7") Then Goto Line105
If cell = ("\$K\$7") Then Goto Line110
If cell = ("\$L\$7") Then Goto Line115
If cell = ("\$M\$7") Then Goto Line120
If cell = ("\$N\$7") Then Goto Line125
If cell = ("\$O\$7") Then Goto Line130
If cell = ("\$P\$7") Then Goto Line135
If cell = ("\$C\$10") Then Goto Line140
If cell = ("\$D\$10") Then Goto Line145
If cell = ("\$E\$10") Then Goto Line150
If cell = ("\$F\$10") Then Goto Line155
If cell = ("\$G\$10") Then Goto Line160
If cell = ("\$H\$10") Then Goto Line165
If cell = ("\$I\$10") Then Goto Line170
If cell = ("\$J\$10") Then Goto Line175
If cell = ("\$K\$10") Then Goto Line180
If cell = ("\$L\$10") Then Goto Line185
If cell = ("\$M\$10") Then Goto Line190
If cell = ("\$N\$10") Then Goto Line195
If cell = ("\$O\$10") Then Goto Line200
If cell = ("\$N\$13") Then Goto Line205
If cell = ("\$O\$13") Then Goto Line210
If cell = ("\$P\$13") Then Goto Line215
If cell = ("\$Q\$13") Then Goto Line220
If cell = ("\$R\$13") Then Goto Line225
If cell = ("\$S\$13") Then Goto Line230
If cell = ("\$R\$15") Then Goto Line235
If cell = ("\$S\$15") Then Goto Line240
If cell = ("\$C\$13") Then Goto Line245
If cell = ("\$D\$13") Then Goto Line250
If cell = ("\$E\$13") Then Goto Line255
If cell = ("\$F\$13") Then Goto Line260
If cell = ("\$G\$13") Then Goto Line265
If cell = ("\$H\$13") Then Goto line270
If cell = ("\$I\$13") Then Goto Line275
If cell = ("\$J\$13") Then Goto Line280
If cell = ("\$K\$13") Then Goto Line285

If cell = ("\$A\$15") Then Goto Line900
If cell = ("\$A\$6") Then Goto Line900
If cell = ("\$J\$6") Then Goto Line900
If cell = ("\$A\$9") Then Goto Line900
If cell = ("\$A\$12") Then Goto Line900
If cell = ("\$L\$12") Then Goto Line900

Goto bottom
Line5:  Selection.AutoFilter Field:=2, Criteria1:="EJ7"
Selection.AutoFilter Field:=10, Criteria1:="=2G*", Operator:=xlAnd, _
Criteria2:="<>*s*"
Goto bottom1
Line10: Selection.AutoFilter Field:=2, Criteria1:="EJ7"
Selection.AutoFilter Field:=10, Criteria1:="=2GS*", Operator:=xlAnd
Line15: Selection.AutoFilter Field:=2, Criteria1:="EJ7"
Selection.AutoFilter Field:=10, Criteria1:="=3G*", Operator:=xlAnd, _
Criteria2:="<>*s*"
Goto bottom1
Line20: Selection.AutoFilter Field:=2, Criteria1:="EJ7"
Selection.AutoFilter Field:=10, Criteria1:="=3GS*", Operator:=xlAnd
Goto bottom1
Line25: Selection.AutoFilter Field:=2, Criteria1:="EJ7"
Selection.AutoFilter Field:=10, Criteria1:="=4G*", Operator:=xlAnd, _
Criteria2:="<>*s*"
Goto bottom1
Line30: Selection.AutoFilter Field:=2, Criteria1:="EJ7"
Selection.AutoFilter Field:=10, Criteria1:="=4GS*", Operator:=xlAnd
Goto bottom1
Line35: Selection.AutoFilter Field:=2, Criteria1:="EJ7"
Selection.AutoFilter Field:=10, Criteria1:="=*EH", Operator:=xlAnd
Goto bottom1
Line40: Selection.AutoFilter Field:=2, Criteria1:="EJ7"
Selection.AutoFilter Field:=10, Criteria1:="=*H", Operator:=xlAnd, _
Criteria2:="<>*E*"
Goto bottom1
Line45: Selection.AutoFilter Field:=2, Criteria1:="EJ7"
Selection.AutoFilter Field:=10, Criteria1:="=*HM", Operator:=xlAnd
Goto bottom1
Line50: Selection.AutoFilter Field:=2, Criteria1:="EJ7"
Selection.AutoFilter Field:=10, Criteria1:="=*J", Operator:=xlAnd, _
Criteria2:="<>*F*"
Goto bottom1
Line55: Selection.AutoFilter Field:=2, Criteria1:="EJ7"
Selection.AutoFilter Field:=10, Criteria1:="=*K", Operator:=xlAnd, _
Criteria2:="<>*GK"
Goto bottom1
Line60: Selection.AutoFilter Field:=2, Criteria1:="EJ7"
Selection.AutoFilter Field:=10, Criteria1:="=*M", Operator:=xlAnd, _
Criteria2:="<>*HM"
Goto bottom1
Line65: Selection.AutoFilter Field:=2, Criteria1:="EJ7"
Selection.AutoFilter Field:=10, Criteria1:="=*GK", Operator:=xlAnd
Goto bottom1
Line70: Selection.AutoFilter Field:=2, Criteria1:="EJ7"
Selection.AutoFilter Field:=10, Criteria1:="=*FJ", Operator:=xlAnd
Goto bottom1
Line75: Selection.AutoFilter Field:=2, Criteria1:="BF7"
Selection.AutoFilter Field:=10, Criteria1:="=3H*", Operator:=xlAnd
Goto bottom1
Line80: Selection.AutoFilter Field:=2, Criteria1:="BF7"
Selection.AutoFilter Field:=10, Criteria1:="=4FM*", Operator:=xlAnd
Goto bottom1
Line85: Selection.AutoFilter Field:=2, Criteria1:="BF7"
Selection.AutoFilter Field:=10, Criteria1:="=4H*", Operator:=xlAnd
Goto bottom1
Line90: Selection.AutoFilter Field:=2, Criteria1:="BF7"
Selection.AutoFilter Field:=10, Criteria1:="=*H", Operator:=xlAnd
Goto bottom1
Line95: Selection.AutoFilter Field:=2, Criteria1:="BF7"
Selection.AutoFilter Field:=10, Criteria1:="=*FJ", Operator:=xlAnd
Goto bottom1
Line100:    Selection.AutoFilter Field:=2, Criteria1:="BF7"
Selection.AutoFilter Field:=10, Criteria1:="=*EJ", Operator:=xlAnd
Goto bottom1
Line105:    Selection.AutoFilter Field:=2, Criteria1:="BF7"
Selection.AutoFilter Field:=10, Criteria1:="=*J", Operator:=xlAnd
Goto bottom1
Line110:    Selection.AutoFilter Field:=2, Criteria1:="cg7"
Selection.AutoFilter Field:=10, Criteria1:="=4FM*", Operator:=xlAnd
Goto bottom1
Line115:    Selection.AutoFilter Field:=2, Criteria1:="cg7"
Selection.AutoFilter Field:=10, Criteria1:="=4H*", Operator:=xlAnd
Goto bottom1
Line120:    Selection.AutoFilter Field:=2, Criteria1:="cg7"
Selection.AutoFilter Field:=10, Criteria1:="=*j", Operator:=xlAnd
Goto bottom1
Line125:    Selection.AutoFilter Field:=2, Criteria1:="cg7"
Selection.AutoFilter Field:=10, Criteria1:="=*FJ", Operator:=xlAnd
Goto bottom1
Line130:    Selection.AutoFilter Field:=2, Criteria1:="cg7"
Selection.AutoFilter Field:=10, Criteria1:="=*G", Operator:=xlAnd
Goto bottom1
Line135:    Selection.AutoFilter Field:=2, Criteria1:="cg7"
Selection.AutoFilter Field:=10, Criteria1:="=*G/J", Operator:=xlAnd
Goto bottom1
Line140:  Selection.AutoFilter Field:=2, Criteria1:="dj9"
Selection.AutoFilter Field:=10, Criteria1:="=2EIL*", Operator:=xlAnd
Goto bottom1
Line145:    Selection.AutoFilter Field:=2, Criteria1:="dj9"
Selection.AutoFilter Field:=10, Criteria1:="=2F*", Operator:=xlAnd
Goto bottom1
Line150:    Selection.AutoFilter Field:=2, Criteria1:="dj9"
Selection.AutoFilter Field:=10, Criteria1:="=3EIL*", Operator:=xlAnd
Goto bottom1
Line155:    Selection.AutoFilter Field:=2, Criteria1:="dj9"
Selection.AutoFilter Field:=10, Criteria1:="=3F*", Operator:=xlAnd
Goto bottom1
Line160:    Selection.AutoFilter Field:=2, Criteria1:="dj9"
Selection.AutoFilter Field:=10, Criteria1:="=4EIL*", Operator:=xlAnd
Goto bottom1
Line165:    Selection.AutoFilter Field:=2, Criteria1:="dj9"
Selection.AutoFilter Field:=10, Criteria1:="=4F*", Operator:=xlAnd
Goto bottom1
Line170:    Selection.AutoFilter Field:=2, Criteria1:="dj9"
Selection.AutoFilter Field:=10, Criteria1:="=5EIL*", Operator:=xlAnd
Goto bottom1
Line175:    Selection.AutoFilter Field:=2, Criteria1:="dj9"
Selection.AutoFilter Field:=10, Criteria1:="=*DH", Operator:=xlAnd
Goto bottom1
Line180:   Selection.AutoFilter Field:=2, Criteria1:="dj9"
Selection.AutoFilter Field:=10, Criteria1:="=*FK", Operator:=xlAnd
Goto bottom1
Line185:    Selection.AutoFilter Field:=2, Criteria1:="dj9"
Selection.AutoFilter Field:=10, Criteria1:="=*GM", Operator:=xlAnd
Goto bottom1
Line190:    Selection.AutoFilter Field:=2, Criteria1:="dj9"
Selection.AutoFilter Field:=10, Criteria1:="=*J", Operator:=xlAnd
Goto bottom1
Line195:    Selection.AutoFilter Field:=2, Criteria1:="dj9"
Selection.AutoFilter Field:=10, Criteria1:="=*K", Operator:=xlAnd
Goto bottom1
Line200:    Selection.AutoFilter Field:=2, Criteria1:="dj9"
Selection.AutoFilter Field:=10, Criteria1:="=*M", Operator:=xlAnd
Goto bottom1
Line205:    Selection.AutoFilter Field:=2, Criteria1:="el7"
Selection.AutoFilter Field:=10, Criteria1:="=3GS*", Operator:=xlAnd
Goto bottom1
Line210:    Selection.AutoFilter Field:=2, Criteria1:="el7"
Selection.AutoFilter Field:=10, Criteria1:="=4g*", Operator:=xlAnd
Goto bottom1
Line215:    Selection.AutoFilter Field:=2, Criteria1:="el7"
Selection.AutoFilter Field:=10, Criteria1:="=4GS*", Operator:=xlAnd
Goto bottom1
Line220:    Selection.AutoFilter Field:=2, Criteria1:="el7"
Selection.AutoFilter Field:=10, Criteria1:="=5g*", Operator:=xlAnd
Goto bottom1
Line225:    Selection.AutoFilter Field:=2, Criteria1:="el7"
Selection.AutoFilter Field:=10, Criteria1:="=*J", Operator:=xlAnd
Goto bottom1
Line230:    Selection.AutoFilter Field:=2, Criteria1:="el7"
Selection.AutoFilter Field:=10, Criteria1:="=*HM", Operator:=xlAnd
Goto bottom1
Line235:    Selection.AutoFilter Field:=2, Criteria1:="el7"
Selection.AutoFilter Field:=10, Criteria1:="=*K", Operator:=xlAnd
Goto bottom1
Line240:    Selection.AutoFilter Field:=2, Criteria1:="el7"
Selection.AutoFilter Field:=10, Criteria1:="=*M", Operator:=xlAnd
Goto bottom1
Line245:    Selection.AutoFilter Field:=2, Criteria1:="BL5"
Selection.AutoFilter Field:=10, Criteria1:="=2EI*", Operator:=xlAnd
Goto bottom1
Line250:    Selection.AutoFilter Field:=2, Criteria1:="BL5"
Selection.AutoFilter Field:=10, Criteria1:="=3EI*", Operator:=xlAnd
Goto bottom1
Line255:    Selection.AutoFilter Field:=2, Criteria1:="BL5"
Selection.AutoFilter Field:=10, Criteria1:="=4EI*", Operator:=xlAnd
Goto bottom1
Line260:    Selection.AutoFilter Field:=2, Criteria1:="BL5"
Selection.AutoFilter Field:=10, Criteria1:="=*E/F", Operator:=xlAnd
Goto bottom1
Line265:    Selection.AutoFilter Field:=2, Criteria1:="BL5"
Selection.AutoFilter Field:=10, Criteria1:="=*F", Operator:=xlAnd
Goto bottom1
line270:    Selection.AutoFilter Field:=2, Criteria1:="BL5"
Selection.AutoFilter Field:=10, Criteria1:="=*G", Operator:=xlAnd
Goto bottom1
Line275:    Selection.AutoFilter Field:=2, Criteria1:="BL5"
Selection.AutoFilter Field:=10, Criteria1:="=*H", Operator:=xlAnd
Goto bottom1
Line280:    Selection.AutoFilter Field:=2, Criteria1:="BL5"
Selection.AutoFilter Field:=10, Criteria1:="=*J", Operator:=xlAnd
Goto bottom1
Line285:    Selection.AutoFilter Field:=2, Criteria1:="BL5"
Selection.AutoFilter Field:=10, Criteria1:="=*K", Operator:=xlAnd
Goto bottom1

Goto bottom

Line900:    Selection.AutoFilter Field:=2
Selection.AutoFilter Field:=10

bottom1: Range("E3").Select
ActiveCell.FormulaR1C1 = ""
Range("E3").Value = "FAILED"
Range("A14").Select

Range("G3").Select
ActiveCell.FormulaR1C1 = ""
Range("G3").Value = "AT RISK"
Range("A14").Select

Range("I3").Select
ActiveCell.FormulaR1C1 = ""
Range("I3").Value = "OVERHAULED"
Range("A14").Select

Range("L3").Select
ActiveCell.FormulaR1C1 = ""
Range("L3").Value = "INSPECTED"
Range("A14").Select

Range("O3").Select
ActiveCell.FormulaR1C1 = ""
Range("O3").Value = "REPAIRED"
Range("A14").Select

Range("R3").Select
ActiveCell.FormulaR1C1 = ""
Range("R3").Value = "SCRAP"
Range("A14").Select
bottom:
Application.ScreenUpdating = True
End Sub

```
(The end bit after line 285 was in before I received the information about subtotalling colors)
Last edited by royUK; January 7th, 2006 at 16:12. Reason: adding code tags please us in future

Excel Video Tutorials / Excel Dashboards Reports

6. ## Re: Subtotalling cell colours

First bit is easy

VB:
```=SUMPRODUCT((SUBTOTAL(3,OFFSET(B12,ROW(B12:B5989)-MIN(ROW(B12:B5989)),,1))),--(B12:B5989="ej7"),--(LEFT(J12:J5989,3)="4GS"))

```

7. Super Moderator
Join Date
26th January 2003
Location
Derbyshire,UK
Posts
19,448
Usergroup
Super Moderators

## Re: Subtotalling cell colours

I have added code tags for you in this post.Please read the rules you agreed to particularly concerning Code tags & their use. Thanks

There are currently 1 users browsing this thread. (0 members and 1 guests)

#### Posting Permissions

• You may not post new threads
• You may not post replies
• You may not post attachments
• You may not edit your posts
•
porno