Find cells within range equal to 70% of sum of total range

Hi everyone,

New to the site and a beginner with VBA. I have told someone at work i will help them sort out a spreadsheet problem but I am struggling(I need to keep this job so I agreed!!). They input new data into a spreadsheet each day and have to from that range find the sum of the data. They then find the value of 70% of this sum. From the maximum value in the range they then count one cell up, one cell down starting with the larger each time adding to the max value until it reaches the 70% of total figure.
I have tried endlessly with if functions and sumifs, and every other formula i could imagine without success. I have tried using percentiles too but it selects highest value numbers not those directly one cell up or down without leaving a gap in the range.

Someone suggested VBA would work and I have been reading books on how to do this but i do not know where to start. If someone could even get me started it would be much appreciated. Attached is an example of what I am trying to achieve.

I hope you guy's can help as this is something I want to learn and develop some skills in, unfortunately this project I am a bit rushed on time.

Thanks again in advance,

KevB

Well, we will have to see what we can do to help you keep that job.

Looking at the spreadsheet, I don't understand how you come to the result that rows 5-21 form the 70% rule. Can you explain how you come to that?

Hi xld

Sure thing, the sum of these cells is as close to the value of the in the cell labelled 70%, which represents 70% of the total sum of all the cells.

I am working off the values in the volume column for this, sorry for the confusion

That is what I feared you would say. A couple more questions

- is closest value the closest ABSOLUTE value, in other words is a sum of 250 closer to 300 ( difference is -50) than say 360 (a difference of +60)

- does the 70% range have to be contiguous (if the answer is no, I think I will give up now)

- how much data will there be in reality

-It doesnt matter if it is above or below the value so long as it is close.
-I will say yes so you don't give up!!
- There should be no more than 30-40 in the range at max.

sorry so yes absolute values would be better but if it cant be done that is ok

Absolute is not a problem.

I have just knocked up some code, and this tells me that rows 14-44 is closer to the 70% than your highlighted range. Can you confirm this, or tell me where I am going wrong?

The equation for starting to add to the 70% figure must start with the max cell and from this point work up and down. So the formula must start with cell B16 (which has the highest value of 2152 in it) then add to it B17 and B15 then B18 and/or B14 until we reach the target number.

Okay, I see what you mean now, but I still get a different range. My code finds B12:B33 to be closer by quite a magnitude.

I have not tested this fully but your rules would seem to indicate that the answer would be B11:B26. You might want to be sure that your manual example meets the criterion as defined. It helps keep us from making guesses.

[vba]Sub test_r70p()
MsgBox r70P.Address
End Sub

Function r70P() As Range
Dim sRow As Long, lRow As Long
Dim rColB As Range, rMaxVal As Range, r70 As Range
Dim cell As Range, r As Range, r1 As Range, r2 As Range
Dim maxVal As Long, sumVal As Long, lrColB As Long
Dim topVal As Long, botVal As Long, cVal As Long
Dim rTop As Range, rBot As Range

Set rColB = Range("B2", Range("B2").End(xlDown))
lrColB = rColB.Cells(rColB.Rows.Count, rColB.Columns.Count).Row
sumVal = WorksheetFunction.Sum(rColB)

maxVal = WorksheetFunction.Max(rColB)
'Find the cell with the maximum value
For Each cell In rColB
If cell.Value2 = maxVal Then
Set rMaxVal = cell
Set r70 = cell
Set rTop = cell
Set rBot = cell
Exit For
End If
Next cell

Do
topVal = rTop.Offset(-1).Value2
botVal = rBot.Offset(1).Value2
If topVal >= botVal Then
Set rTop = rTop.Offset(-1)
Else: Set rBot = rBot.Offset(1)
End If
Set r70 = Range(rTop, rBot)
Loop Until WorksheetFunction.Sum(r70) / sumVal >= 0.7 Or _
(rTop.Row = 2 And rBot.Row = lrColB)

Set r70P = r70
End Function
[/vba]

wow guys this is excellent, how good is this site!!!
I will run this now and see what i get and yes i will double check that the manual example works as per above.
thankyou very much, i may be back with more questions later if that is ok and i will definitely give you guys an update.

Thanks again for all your help!!

Hi Guys,

When I try to run it I get error 91 and this line highlighted, any suggestions?


lrColB = rColB.Cells(rColB.Rows.Count, rColB.Columns.Count).Row


Also do I need to reference any of the cells in the worksheet to match the code you have written?

Show us the sample workbook with the range you tried this code within. You can attach a workbook by clicking on Go Advanced then scrolling down to Manage Attachments and follow the directions from there.

I did not see that error in my test with your data. I did change one line of code after the Do to:
[vba] If rTop.Row <> 2 Then topVal = rTop.Offset(-1).Value2
[/vba]
Here is your example with my code. I added the data to two sheets with two types of sorts to test those scenarios.

Once the expected range is found, it is easy to use the code to set the interior colors and run the code dynamically.