Excel Formula Question

[AccessUser123]

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.

[Rabbit]

No such function exists. You will have to create it.

[AccessUser123]

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

Sub findsums()
'This *REQUIRES* VBAProject references to
 'Microsoft Scripting Runtime
 'Microsoft VBScript Regular Expressions 1.0 or higher

 Const TOL As Double = 0.000001  'modify as needed
 Dim c As Variant

 Dim j As Long, k As Long, n As Long, p As Boolean
 Dim s As String, t As Double, u As Double
 Dim v As Variant, x As Variant, y As Variant
 Dim dc1 As New Dictionary, dc2 As New Dictionary
 Dim dcn As Dictionary, dco As Dictionary
 Dim re As New RegExp

 re.Global = True
 re.IgnoreCase = True

 On Error Resume Next

 Set x = Application.InputBox( _
   Prompt:="Enter range of values:", _
   Title:="findsums", _
   Default:="", _
   Type:=8 _
 )

 If x Is Nothing Then
   Err.Clear
   Exit Sub
 End If

 y = Application.InputBox( _
   Prompt:="Enter target value:", _
   Title:="findsums", _
   Default:="", _
   Type:=1 _
 )

 If VarType(y) = vbBoolean Then
   Exit Sub
 Else
   t = y
 End If

 On Error GoTo 0

 Set dco = dc1
 Set dcn = dc2

 Call recsoln

 For Each y In x.Value2
   If VarType(y) = vbDouble Then
     If Abs(t - y) < TOL Then
       recsoln "+" & Format(y)

     ElseIf dco.Exists(y) Then
       dco(y) = dco(y) + 1

     ElseIf y < t - TOL Then
       dco.Add Key:=y, Item:=1

       c = CDec(c + 1)
       Application.StatusBar = "[1] " & Format(c)

     End If

   End If
 Next y

 n = dco.Count

 ReDim v(1 To n, 1 To 3)

 For k = 1 To n
   v(k, 1) = dco.Keys(k - 1)
   v(k, 2) = dco.Items(k - 1)
 Next k

 qsortd v, 1, n

 For k = n To 1 Step -1
   v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3)
   If v(k, 3) > t Then dcn.Add Key:="+" & _
     Format(v(k, 1)), Item:=v(k, 1)
 Next k

 On Error GoTo CleanUp
 Application.EnableEvents = False
 Application.Calculation = xlCalculationManual

 For k = 2 To n
   dco.RemoveAll
   swapo dco, dcn

   For Each y In dco.Keys
     p = False

     For j = 1 To n
       If v(j, 3) < t - dco(y) - TOL Then Exit For
       x = v(j, 1)
       s = "+" & Format(x)
       If Right(y, Len(s)) = s Then p = True
       If p Then
         re.Pattern = "\" & s & "(?=(\+|$))"
         If re.Execute(y).Count < v(j, 2) Then
           u = dco(y) + x
           If Abs(t - u) < TOL Then
             recsoln y & s
           ElseIf u < t - TOL Then
             dcn.Add Key:=y & s, Item:=u
             c = CDec(c + 1)
             Application.StatusBar = "[" & Format(k) & "] " & _
                 Format(c)
           End If
         End If
       End If
     Next j
   Next y

   If dcn.Count = 0 Then Exit For
 Next k

 If (recsoln() = 0) Then _
   MsgBox Prompt:="all combinations exhausted", _
     Title:="No Solution"

CleanUp:
 Application.EnableEvents = True
 Application.Calculation = xlCalculationAutomatic
 Application.StatusBar = False

End Sub

Private Function recsoln(Optional s As String)
 Const OUTPUTWSN As String = "findsums solutions"  'modify to taste

 Static r As Range
 Dim ws As Worksheet

 If s = "" And r Is Nothing Then
   On Error Resume Next
   Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN)
   If ws Is Nothing Then
     Err.Clear
     Application.ScreenUpdating = False
     Set ws = ActiveSheet
     Set r = Worksheets.Add.Range("A1")
     r.Parent.Name = OUTPUTWSN
     ws.Activate
     Application.ScreenUpdating = False
   Else
     ws.Cells.Clear
     Set r = ws.Range("A1")
   End If
   recsoln = 0
 ElseIf s = "" Then
   recsoln = r.Row - 1
   Set r = Nothing
 Else
   r.Value = s
   Set r = r.Offset(1, 0)
   recsoln = r.Row - 1
 End If
End Function

Private Sub qsortd(v As Variant, lft As Long, rgt As Long)
 'ad hoc quicksort subroutine
 'translated from Aho, Weinberger & Kernighan,
 '"The Awk Programming Language", page 161

 Dim j As Long, pvt As Long

 If (lft >= rgt) Then Exit Sub
 swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd)
 pvt = lft
 For j = lft + 1 To rgt
   If v(j, 1) > v(lft, 1) Then
     pvt = pvt + 1
     swap2 v, pvt, j
   End If
 Next j

 swap2 v, lft, pvt

 qsortd v, lft, pvt - 1
 qsortd v, pvt + 1, rgt
End Sub

Private Sub swap2(v As Variant, i As Long, j As Long)
 'modified version of the swap procedure from
 'translated from Aho, Weinberger & Kernighan,
 '"The Awk Programming Language", page 161

 Dim t As Variant, k As Long

 For k = LBound(v, 2) To UBound(v, 2)
   t = v(i, k)
   v(i, k) = v(j, k)
   v(j, k) = t
 Next k
End Sub

Private Sub swapo(a As Object, b As Object)
 Dim t As Object

 Set t = a
 Set a = b
 Set b = t
End Sub
'---- end VBA code ----

[kjv1611]

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

[AccessUser123]

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.

[Widukind]

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.