438,323 Members | 1,216 Online 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
5 Replies

 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 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 = " " & 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 ---- 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 