Excel

Formula to Total Cells with Same Fill Color

Ease of Use

Easy

Version tested with

2000, 2003 

Submitted by:

mdmackillop

Description:

The code will write into a target cell, or range of cells, the =C1+C3+C17 type formula to total the cells of the same colour, above the target cell, terminating if a "Stop" colour is inserted. 

Discussion:

This provides a quick way to total categories which are identified on a spreadsheet by use of colour (or no colour). Set the required colour in the target cell at the bottom of your column of figures and run the macro to write the formula. The references for blank cells are included within the formula, so the totals will change if data is inserted in these cells later. If you wish to put a break in the column, enter a red cell (as coded), alternatively you can identify a cell on your worksheet which is coloured, and set this as your "break" colour, by amending the indicated line. There is an option to avoid counting uncoloured cells, by removing the apostophes preceding the three code lines between the asterisks. 

Code:

instructions for use 

			
Option Explicit 
 
Sub AddColour() 
     
    Dim Colour As Integer, Stops As Long 
    Dim CellAdd As String, CurCell As String 
    Dim CellRow As Long 
    Dim i As Long, Cell As Range 
     
    Application.ScreenUpdating = False 
    Stops = 3 'Stops if red cell is found or
     'Stops = Range("A1").Interior.ColorIndex  'Set own Stop colour in suitable location
     'Get colour of target cell to be totalled.
     
    For Each Cell In Selection 
        CellAdd = "" 
        i = 0 
        CellRow = Cell.Row() 
        Colour = Cell.Interior.ColorIndex 
         
         '************************************************
         'Goes to next cell if no colour selected.
         'Remove the apostrophes from the following three lines to omit uncoloured cells
         'If Colour = xlNone Then
         '    GoTo Skipped
         'End If
         '************************************************
Restart: 
         'Check each cell above target cell and set CurCell to cell address if true
        i = i + 1 
        If Cell.Offset(-i, 0).Interior.ColorIndex = Colour Then 
            CurCell = Cell.Offset(-i, 0).Address(False, False) 
            On Error Resume Next 
             'Create formula of cell addresses
            CellAdd = CurCell & "+" & CellAdd 
            If Cell.Offset(-i, 0).Row() = 1 Then GoTo Finish 
            GoTo Restart 
        Else 
             'Stop processing if Stop colour or top of sheet is found
            If Cell.Offset(-i, 0).Interior.ColorIndex = Stops Then GoTo Finish 
            If Cell.Offset(-i, 0).Row() = 1 Then GoTo Finish 
            On Error GoTo Finish 
            GoTo Restart 
        End If 
Finish: 
         'Trim last + sign and write to target cell
        Cell.Formula = "=" & Left(CellAdd, Len(CellAdd) - 1) 
Skipped: 
    Next Cell 
     
    Application.ScreenUpdating = True 
End Sub

How to use:

  1. Copy the code above.
  2. Open Excel
  3. Hit Alt+F11 to open the Visual Basic Editor.
  4. Right click VBAProject (Personal.xls) at the left.
  5. Choose Insert-Module, and paste the code into the window at the right.
  6. Hit the Save diskette button and close the VBE.
 

Test the code:

  1. Enter some numbers into a column
  2. Apply colours to some of the cells, and the same colour to blank cells below.
  3. Select the bottom coloured cell(s), hit Alt+F8, select the AddColour macro and select run.
  4. Add a red coloured cell in the column, the count should stop at that cell.
 

Sample File:

AddColour.zip 10.12KB 

Approved by lucas


This entry has been viewed 81 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express