Trying every possible sum combination

**Caligula** · 03-23-2009, 12:01 PM

Hi all,

I have a project where I need to cycle through the number of rows to sum and which rows need summing.

For example, if column G has six values in it, I want it to first look for single row that equal zero and delete them. After that, I want it to look at any two rows that when added equal zero, e.g. G1+G(2->6) then G2+G(3->6). If that doesn't work, I want it to look at three rows, e.g. G1+G2+G(3->6), G1+G3+G(4->6), etc, etc.

I'm having a really hard time with the logic for this; everything I write duplicates the calc's or skips rows, etc. Does anyone have any code that already does something like this?

Thanks!
Chris

**shg** · 03-23-2009, 12:15 PM

How about posting a workbook with some examples?

**Caligula** · 03-23-2009, 12:22 PM

I've attached a sample of the data I'd be looking at. As you can see, there are 89 distinct values in column G, so there would be a lot of possible combinations. Hope this helps.

**shg** · 03-23-2009, 12:35 PM

So G2 contains 13,346.57, and you want to find one or more cells below that sum to -13,346.57, and zero all those out, then go down column G and repeat the process?

That's a non-trivial exercise. Tushar Mehta wrote some code that will find combinations that add to a total. You'd have to wrap that with some more code.

**Caligula** · 03-23-2009, 01:11 PM

That's exactly what I want to do. Do you know where I can find the code that he wrote ?

**shg** · 03-23-2009, 01:16 PM

Sub ComboSum(dTgt As Double, MaxSoln As Integer, rInp As Range)
    ' from http://www.tushar-mehta.com/excel/templates/match_values/index.html

    ' Lists the cells in single-column range rInp that total dTgt
    ' MaxSoln is the number of solutions wanted. Specify zero for all.
    ' Solutions are listed in the column to the right of rInp
    
    Const dEps  As Double = 0.00000001
    Const sSep  As String = ", "

    Dim asSoln() As String  ' solutions
    Dim vInp()  As Variant  ' values in rInp
    Dim daBeg   As Date     ' start time

    Dim WF      As WorksheetFunction

    If rInp.Columns.Count <> 1 Then Exit Sub
    Set WF = Application.WorksheetFunction
    daBeg = Now()
    
    ' get the values from the range
    vInp = WF.Transpose(WF.Transpose(WF.Transpose(rInp.Value)))
    ReDim asSoln(0 To 0)

    RecursiveMatch MaxSoln, dTgt, vInp(), LBound(vInp), 0, dEps, asSoln, "", sSep

    ' list the solutions
    asSoln(UBound(asSoln)) = "Done @ " & Format(Now(), "hh:mm:ss")
    rInp.Offset(, 1).Resize(UBound(asSoln) + 1, 1).Value = WF.Transpose(asSoln)
End Sub

Sub RecursiveMatch(ByVal MaxSoln As Integer, _
                   ByVal dTgt As Double, _
                   ByRef vInp() As Variant, _
                   ByVal iCurrInx As Integer, _
                   ByVal dCurrTot As Double, _
                   ByVal dEps As Double, _
                   ByRef asSoln() As String, _
                   ByVal sSoln As String, _
                   ByVal sSep As String)

    Dim i       As Integer

    For i = iCurrInx To UBound(vInp)
        If Abs(dCurrTot + vInp(i) - dTgt) <= dEps Then
            asSoln(UBound(asSoln)) = dCurrTot + vInp(i) _
                                     & sSep & Format(Now(), "hh:mm:ss") _
                                     & sSoln & sSep & CStr(i)
            If UBound(asSoln) Mod 100 = 0 Then Debug.Print UBound(asSoln) + 1 & " solutions ..."
            If MaxSoln <> 0 Then If UBound(asSoln) >= MaxSoln Then Exit Sub
            ReDim Preserve asSoln(UBound(asSoln) + 1)

        ElseIf dCurrTot + vInp(i) < dTgt - dEps And iCurrInx < UBound(vInp) Then
            RecursiveMatch MaxSoln, dTgt, vInp(), i + 1, _
                           dCurrTot + vInp(i), dEps, asSoln(), _
                           sSoln & sSep & CStr(i), sSep
            If MaxSoln <> 0 Then If UBound(asSoln) >= MaxSoln Then Exit Sub

        End If
    Next i
End Sub