Hello everybody
I have numbers in range("A2:A" & lastrow)
In D3 I have a number which is considered the sum of some values in range("A2:A" & lastrow)
Here's an attachment to illustarte the expected results
Hello everybody
I have numbers in range("A2:A" & lastrow)
In D3 I have a number which is considered the sum of some values in range("A2:A" & lastrow)
Here's an attachment to illustarte the expected results
Here, try this:
Use function as:Function SUMBYCOLOR(rng As Range, criteria As Range) Dim Sum As Double On Error Resume Next For Each r In rng If r.Interior.ColorIndex = criteria.Interior.ColorIndex Then Sum = Sum + r.Value End If Next r SUMBYCOLOR = Sum End Function
Formula:=SUMBYCOLOR(A1:A100, A10)
Where first range (A1:A100) is SUM range and second cell (A10) is criteria for color you want to sum.
Not sure exactly what you are trying to achieve.
In col. A, have you colored the range A7:A14 because the Sum(A7:A14) is equal to D3 i.e. 42?
If yes, then why not A4:A13 because sum of this range is also equal to 42?
You may try this to see if this is what you are trying to achieve.
Sub ColorSumRange() Dim i As Long, j As Long, lr As Long, SumVal As Double, rSum As Double SumVal = Range("D3").Value lr = Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To lr rSum = Cells(i, 1) For j = i + 1 To lr rSum = rSum + Cells(j, 1) If rSum = SumVal Then Range(Cells(i, 1), Cells(j, 1)).Interior.ColorIndex = 3 Exit Sub ElseIf rSum > SumVal Then Exit For End If Next j Next i End Sub
Last edited by sktneer; 05-05-2015 at 06:55 AM. Reason: Correction in variable type.
Regards
sktneer
Treat people the way you want to be treated. Talk to people the way you want to be talked to.
Respect is earned NOT given.
Mr. zbor
Thanks for this nice and useful function .. but it is not required here
Mr. sktneer
Great solution and very good ..
I wondered is there a way to extract the different possibilties to adjacent columns ..
To extract the possible sum ranges in adjacent columns, you may try this.....
Sub ColorSumRange() Dim i As Long, j As Long, lr As Long, SumVal As Double, rSum As Double, c As Long SumVal = Range("D3").Value lr = Cells(Rows.Count, 1).End(xlUp).Row c = 2 For i = 1 To lr rSum = Cells(i, 1) For j = i + 1 To lr rSum = rSum + Cells(j, 1) If rSum = SumVal Then Range(Cells(i, 1), Cells(j, 1)).Copy Cells(i, c) c = c + 1 Exit For ElseIf rSum > SumVal Then Exit For End If Next j Next i End Sub
Mr. sktneer
This is the most perfect solution for my request
Thanks alot for this great help
You're welcome Yasser!
Glad I could help and thanks for the feedback as well.
There are currently 1 users browsing this thread. (0 members and 1 guests)
Bookmarks