Solved

Excel - Total by Color (Not Using UDF)

Posted on 2014-12-23
4
163 Views
Last Modified: 2014-12-24
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
Comment
Question by:SuraDalbin
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 2
  • 2
4 Comments
 
LVL 5

Expert Comment

by:Hakan Yılmaz
ID: 40516017
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
 

Author Comment

by:SuraDalbin
ID: 40516048
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
 
LVL 5

Accepted Solution

by:
Hakan Yılmaz earned 500 total points
ID: 40516065
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
 

Author Closing Comment

by:SuraDalbin
ID: 40516114
Hakan,

Thank you so much, this works perfectly.  You rock!
0

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.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Do you use a spreadsheet like Microsoft's Excel?  Have you ever wanted to link out to a non excel file on your computer or network drive?  This is the way I found to do it!
This article describes a serious pitfall that can happen when deleting shapes using VBA.
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

752 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question