Announcement

Collapse
No announcement yet.

Unconfigured Ad Widget

Collapse

Subtotal By Cell Color

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • 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!!

    Code:
    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, 12:44. Reason: add code tags, please use when posting codes

  • #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


    '---------------------------------------------------------------------
    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

    Code:
    =SUMPRODUCT(--(ColorIndex(A1:A20)=3)
    or

    Code:
    =SUMPRODUCT(--(ColorIndex(A1:A20)=ColorIndex(A1))
    The beauty about this is that in your case we can incorporate the hidden cells in the formulam using SUBTOTAL, such as

    Code:
    =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, 12:45.
    HTH

    Bob

    Comment


    • #3
      Re: Subtotalling cell colours

      Thanks Bob, will give it a go tomorrow.

      Steve

      Comment


      • #4
        Re: Subtotalling cell colours

        Let us know how it goes.
        HTH

        Bob

        Comment


        • #5
          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..........

          Code:
           Private Sub Worksheet_SelectionChange(ByVal Target As Range)
            Application.ScreenUpdating = False
            'GoTo bottom
            cell = ActiveCell.Address
              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, 17:12. Reason: adding code tags please us in future

          Comment


          • #6
            Re: Subtotalling cell colours

            First bit is easy

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

            Bob

            Comment


            • #7
              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
              Hope that Helps

              Roy

              New users should read the Forum Rules before posting

              For free Excel tools & articles visit my web site

              If I have helped you and you feel like putting your hand in your pocket please make a donation to Children in Need

              RoyUK's Web Site

              royUK's Database Form

              Where to paste code from the Forum

              About me.

              Comment

              Trending

              Collapse

              There are no results that meet this criteria.

              Working...
              X