By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
438,323 Members | 1,216 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 438,323 IT Pros & Developers. It's quick & easy.

Excel Formula Question

P: 5
Is there a function in Excel that will find which cells within a range that sum up to a predetermined value? i.e. I have a range of 1,000 cells with number values and I want to know which cells sum up to 467.
Mar 11 '11 #1
Share this Question
Share on Google+
5 Replies


Rabbit
Expert Mod 10K+
P: 12,369
No such function exists. You will have to create it.
Mar 11 '11 #2

P: 5
I just found the VB Code to do it and it works great!
Code by Harlan Grove

Expand|Select|Wrap|Line Numbers
  1. Sub findsums()
  2. 'This *REQUIRES* VBAProject references to
  3.  'Microsoft Scripting Runtime
  4.  'Microsoft VBScript Regular Expressions 1.0 or higher
  5.  
  6.  Const TOL As Double = 0.000001  'modify as needed
  7.  Dim c As Variant
  8.  
  9.  Dim j As Long, k As Long, n As Long, p As Boolean
  10.  Dim s As String, t As Double, u As Double
  11.  Dim v As Variant, x As Variant, y As Variant
  12.  Dim dc1 As New Dictionary, dc2 As New Dictionary
  13.  Dim dcn As Dictionary, dco As Dictionary
  14.  Dim re As New RegExp
  15.  
  16.  re.Global = True
  17.  re.IgnoreCase = True
  18.  
  19.  On Error Resume Next
  20.  
  21.  Set x = Application.InputBox( _
  22.    Prompt:="Enter range of values:", _
  23.    Title:="findsums", _
  24.    Default:="", _
  25.    Type:=8 _
  26.  )
  27.  
  28.  If x Is Nothing Then
  29.    Err.Clear
  30.    Exit Sub
  31.  End If
  32.  
  33.  y = Application.InputBox( _
  34.    Prompt:="Enter target value:", _
  35.    Title:="findsums", _
  36.    Default:="", _
  37.    Type:=1 _
  38.  )
  39.  
  40.  If VarType(y) = vbBoolean Then
  41.    Exit Sub
  42.  Else
  43.    t = y
  44.  End If
  45.  
  46.  On Error GoTo 0
  47.  
  48.  Set dco = dc1
  49.  Set dcn = dc2
  50.  
  51.  Call recsoln
  52.  
  53.  For Each y In x.Value2
  54.    If VarType(y) = vbDouble Then
  55.      If Abs(t - y) < TOL Then
  56.        recsoln "+" & Format(y)
  57.  
  58.      ElseIf dco.Exists(y) Then
  59.        dco(y) = dco(y) + 1
  60.  
  61.      ElseIf y < t - TOL Then
  62.        dco.Add Key:=y, Item:=1
  63.  
  64.        c = CDec(c + 1)
  65.        Application.StatusBar = "[1] " & Format(c)
  66.  
  67.      End If
  68.  
  69.    End If
  70.  Next y
  71.  
  72.  n = dco.Count
  73.  
  74.  ReDim v(1 To n, 1 To 3)
  75.  
  76.  For k = 1 To n
  77.    v(k, 1) = dco.Keys(k - 1)
  78.    v(k, 2) = dco.Items(k - 1)
  79.  Next k
  80.  
  81.  qsortd v, 1, n
  82.  
  83.  For k = n To 1 Step -1
  84.    v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3)
  85.    If v(k, 3) > t Then dcn.Add Key:="+" & _
  86.      Format(v(k, 1)), Item:=v(k, 1)
  87.  Next k
  88.  
  89.  On Error GoTo CleanUp
  90.  Application.EnableEvents = False
  91.  Application.Calculation = xlCalculationManual
  92.  
  93.  For k = 2 To n
  94.    dco.RemoveAll
  95.    swapo dco, dcn
  96.  
  97.    For Each y In dco.Keys
  98.      p = False
  99.  
  100.      For j = 1 To n
  101.        If v(j, 3) < t - dco(y) - TOL Then Exit For
  102.        x = v(j, 1)
  103.        s = "+" & Format(x)
  104.        If Right(y, Len(s)) = s Then p = True
  105.        If p Then
  106.          re.Pattern = "\" & s & "(?=(\+|$))"
  107.          If re.Execute(y).Count < v(j, 2) Then
  108.            u = dco(y) + x
  109.            If Abs(t - u) < TOL Then
  110.              recsoln y & s
  111.            ElseIf u < t - TOL Then
  112.              dcn.Add Key:=y & s, Item:=u
  113.              c = CDec(c + 1)
  114.              Application.StatusBar = "[" & Format(k) & "] " & _
  115.                  Format(c)
  116.            End If
  117.          End If
  118.        End If
  119.      Next j
  120.    Next y
  121.  
  122.    If dcn.Count = 0 Then Exit For
  123.  Next k
  124.  
  125.  If (recsoln() = 0) Then _
  126.    MsgBox Prompt:="all combinations exhausted", _
  127.      Title:="No Solution"
  128.  
  129. CleanUp:
  130.  Application.EnableEvents = True
  131.  Application.Calculation = xlCalculationAutomatic
  132.  Application.StatusBar = False
  133.  
  134. End Sub
  135.  
  136. Private Function recsoln(Optional s As String)
  137.  Const OUTPUTWSN As String = "findsums solutions"  'modify to taste
  138.  
  139.  Static r As Range
  140.  Dim ws As Worksheet
  141.  
  142.  If s = "" And r Is Nothing Then
  143.    On Error Resume Next
  144.    Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN)
  145.    If ws Is Nothing Then
  146.      Err.Clear
  147.      Application.ScreenUpdating = False
  148.      Set ws = ActiveSheet
  149.      Set r = Worksheets.Add.Range("A1")
  150.      r.Parent.Name = OUTPUTWSN
  151.      ws.Activate
  152.      Application.ScreenUpdating = False
  153.    Else
  154.      ws.Cells.Clear
  155.      Set r = ws.Range("A1")
  156.    End If
  157.    recsoln = 0
  158.  ElseIf s = "" Then
  159.    recsoln = r.Row - 1
  160.    Set r = Nothing
  161.  Else
  162.    r.Value = s
  163.    Set r = r.Offset(1, 0)
  164.    recsoln = r.Row - 1
  165.  End If
  166. End Function
  167.  
  168. Private Sub qsortd(v As Variant, lft As Long, rgt As Long)
  169.  'ad hoc quicksort subroutine
  170.  'translated from Aho, Weinberger & Kernighan,
  171.  '"The Awk Programming Language", page 161
  172.  
  173.  Dim j As Long, pvt As Long
  174.  
  175.  If (lft >= rgt) Then Exit Sub
  176.  swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd)
  177.  pvt = lft
  178.  For j = lft + 1 To rgt
  179.    If v(j, 1) > v(lft, 1) Then
  180.      pvt = pvt + 1
  181.      swap2 v, pvt, j
  182.    End If
  183.  Next j
  184.  
  185.  swap2 v, lft, pvt
  186.  
  187.  qsortd v, lft, pvt - 1
  188.  qsortd v, pvt + 1, rgt
  189. End Sub
  190.  
  191. Private Sub swap2(v As Variant, i As Long, j As Long)
  192.  'modified version of the swap procedure from
  193.  'translated from Aho, Weinberger & Kernighan,
  194.  '"The Awk Programming Language", page 161
  195.  
  196.  Dim t As Variant, k As Long
  197.  
  198.  For k = LBound(v, 2) To UBound(v, 2)
  199.    t = v(i, k)
  200.    v(i, k) = v(j, k)
  201.    v(j, k) = t
  202.  Next k
  203. End Sub
  204.  
  205. Private Sub swapo(a As Object, b As Object)
  206.  Dim t As Object
  207.  
  208.  Set t = a
  209.  Set a = b
  210.  Set b = t
  211. End Sub
  212. '---- end VBA code ----
Mar 11 '11 #3

P: 4
That code looks interesting, though I don't know of a current need, I could see the need in the future. Can you give an idea of how well it performs? I mean how long does it normally take for this to run and find the solution? Does it take "a while", or is it practically instant?

Thanks
May 19 '11 #4

P: 5
I have not run this code on very large sets of data, but shows instant results on the 100-200 rows of data that I have tested it on. Hope this helps.
May 20 '11 #5

P: 1
The number of subsets of a finite set is 2 raised to the number of members of the set. In your set of a thousand cells, you want to check all possible subsets of cells, like the subset {A4, B19, C2} and the subset {B12, B13, C13, C14, D943, D945}, to name just two of the really small ones. The biggest one will have 1000 members.

There are 2 raised to the 1000th power such subsets. Let us say the average set contains 500 cells and it takes one nanosecond to calculate such a sum and compare it to the number 467. ( Of course it takes longer, but as you will see, it doesn't matter). Checking all possible sums then takes 2^1000 / (1,000,000,000 * 60 * 60 * 24 * 365.2425) years. That number of years is a bit more than the number 3 with 284 zeros after it. Our sun will become a red giant in 1500000000 years. Its radius will then be approximately equal to that of Earth's orbit; the temperature where you are sitting will be about 1500 degrees Celsius. The result of the calculation will not matter to you then. And the calculation process will still be at its very earliest beginning, so much so that you might as well start over without noticing the difference.

Simply put: you will never get the answer. I don't think parallel computing is the answer either, because the number of computers needed would have to be considerably greater than the number of atoms in the universe raised to three to achieve anything.

This is why I know that the code that was posted cannot not do what you want, even without looking at it. But I looked at it anyway and learnt something, so Thanks, guys. It hadn't occurred to me to use VBScript in Excel. Usually, if I want to do something fancy like that, I open a workbook from VB 2005 and use Excel as a slave to serve as a front end, but I now realize that VBScript may sometimes be useful, and that was interesting.

The problem is, by the way, a real one, with non-academic applications, and I can make one up right now: Suppose you get a sum of money from a customer who has 40 outstanding invoices. You sum the oldest ones but they do not add upp to this amount. Which ones did she mean to pay?

While I am writing this, the code is running in Excel, on a range containing 102 different numbers. I hardly think it will finish today, so I stopped it now with the Task Manager. Then I entered a range of 24 numbers, and Wham!, it finished in less than a second, and it found many answers, too, so it sometimes does work as advertised. Then I entered a grid containing the digit 1 in 24 cells, asked the program to find the sum 8. It did not find 1+1+1+1+1+1+1+1 even once and wasn't designed to.

Let's look at some more realistic examples. If 24 numbers takes one second, how long should 25 numbers take? Answer: 2 seconds. The reason is that the new number can either be combined with an exsisting sum or not combined with an existing sum, and that is two possibilities for each existing sum. The number of possible sums gets multiplied by two for every cell you add, so calculation time should be roughly doubled. 26 numbers then take 4 seconds, 28 numbers 8 seconds, 29 numbers 16 seconds, etcetera. At least, a program that a) didn't skip any possibilities and b) didn't have any overhead, would behave in that manner.

Below forty numbers, you can perhaps do something with various optimizing techniques, especially if it is guaranteed that no numbers are negative, above that it helps to have good genes and become really old so you can afford to wait for an answer. 2^40 is already 1.0995e+012.
Jun 3 '13 #6

Post your reply

Sign in to post your reply or Sign up for a free account.