• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 180
  • Last Modified:

Excel - Total by Color (Not Using UDF)

Hello Experts,

I would like to modify the code I came across, which sums all cells that have the same background color, please see attached file, with code.  I am using Excel 2010.  There are two limitations that this code has, which I've been trying to overcome for the past three weeks, but I cannot get it to work.

1. Color Index

By recording a macro in Excel 2010, where I colored cells at random, I noticed that the macro code made reference to the Selection.Interior.Pattern, *.PatternColorIndex, *.ThemeColor, *.TintAndShade, *.PatternTintAndShade instead of just the *.Interior.ColorIndex that the code I have attached in module 1 uses.  In a nutshell, I would like to match the cell background color of my target cell, see D25 in attached file and insert all the matching cell address "=+B13+B14...."

2. Range Of Cells

The second limitation that this code has is that it only applies to cells directly above the target cell, in the attached file, this cell is F25.  Ideally, the macro should prompt user to select range in which to look for the matching cells.
The cells will not be colored using conditional formatting, they'll be directly formatted using the fill color function.

The purpose of all this is for audit-trail purposes, and hence the need to list all cell addresses in one long formula.

Thank you very much for any help you can provide.
Sample-Data---Copy---Copy.xlsm
0
SuraDalbin
Asked:
SuraDalbin
  • 2
  • 2
1 Solution
 
Hakan YılmazTechnical Office MEP EngineerCommented:
First, select the range you want to sum, and run this.
Sub AddColour()
    Dim iterCell As Range
    Dim SRow As Integer
    Dim SCol As Integer
    Application.Calculation = xlCalculationManual
    
    SRow = InputBox("Enter sum cell row")
    SCol = InputBox("Enter sum cell col")
    
    Cells(SRow, SCol).Formula = "="
    For Each iterCell In Selection
        If iterCell.Interior.Color = Cells(SRow, SCol).Interior.Color Then
            Cells(SRow, SCol).Formula = Cells(SRow, SCol).Formula & "+" & iterCell.Address
        End If
    Next iterCell
    Application.Calculation = xlCalculationAutomatic
End Sub

Open in new window

0
 
SuraDalbinAccountantAuthor Commented:
Hello Hakan,

Thank you very much for your response.  I tested the code, but on the first couple of attempts, it seems that the code enters the correct resulting formula in the (row, col) address that I entered in the inputboxes, overwriting the original value in that cell.  This cell however, was supposed to be included in that resulting formula.
To make it a bit more intuitive, can the code prompt the User for two range entries, one would be to select the range to be summed and the second entry would be to ask the User to select the cell that contains the color to be summed?

Thanks again,

Sura
0
 
Hakan YılmazTechnical Office MEP EngineerCommented:
You can use this to write formula to multiple cells based on their colors.

e.g. make a cell green and make a cell red; select them as result cells. It will write sum formulas for both.

Sub AddColour()
    Dim resrange As Range
    Dim iterresrange As Range
    
    Dim sumrange As Range
    Dim itersumrange As Range

    Application.Calculation = xlCalculationManual
    
    Set sumrange = Application.InputBox("select cells you want to include in sums", , , , , , , 8)
    Set resrange = Application.InputBox("select cells you want to write formulas to", , , , , , , 8)
    
    For Each iterresrange In resrange
        iterresrange.Formula = "="
        For Each itersumrange In sumrange
            If itersumrange.Interior.Color = iterresrange.Interior.Color Then
                iterresrange.Formula = iterresrange.Formula & "+" & itersumrange.Address
            End If
        Next itersumrange
    Next iterresrange
    
    Application.Calculation = xlCalculationAutomatic
End Sub

Open in new window


RESULT
0
 
SuraDalbinAccountantAuthor Commented:
Hakan,

Thank you so much, this works perfectly.  You rock!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now