Determine which figures in a number of cells will add up to a set total.

Hi Lianne,

Are you looking for the first combination that can reach the answer, or all combinations of cells in the range? (B2:B6, in your above example)?

That is, if the function were to offer B3, B4 and B5, but another combination (but not from the figures above) was B2, B4, B6, would you like both these to be "returned" as a result?

What is your preference... a list of numbers with a deficit of 1, or an exact match that takes longer to produce?

If the range to search was relatively lengthy (e.g. 2000 cells) then the number of potential results could be quite extensive (and consequently the duration of time taken to produce these results could be too long for your purposes).

Please clarify/advise further.

Thanks.

BFN,

fp.

functionpages>>
-- Are you looking for the first combination that can reach the answer, or all combinations of cells in the range? (B2:B6, in your above example)?
The first combination would suffice as it does not matter which combination is used, though all combinations would be a nice addition.

-- What is your preference... a list of numbers with a deficit of 1, or an exact match that takes longer to produce?
An exact match if possible.

The range is roughly 200 to 300 cells max.

Hope this helps and clarifies things. Thanks.

Lianne

Hi,

I'll address your initial question, and then we can discuss if you need amendments.

Place this code into a code module of your workbook:

=== START OF CODE ===

Option Explicit
Public Function Find_Total(ByRef rngCells As Range, ByVal dblFind_Total As Double)

' Experts Exchange - Q_20864109 [https://www.experts-exchange.com/questions/20864109/Determine-which-figures-in-a-number-of-cells-will-add-up-to-a-set-total.html]
'
' Microsoft Excel: Determine which figures in a number of cells will add up to a set total
'
' (c) Copyright 2004 Clearlogic Concepts (UK) Limited
'
' N.Lee - 27/01/2004 - [http://NigelLee.info]

  Dim dblTotal                                          As Double
  Dim dblValue                                          As Double
  Dim intPos                                            As Integer
  Dim lngLoop                                           As Long
  Dim objCell                                           As Range
  Dim strReturn                                         As String
  Dim strArray()                                        As String
  Dim strResult()                                       As String
 
  On Error Resume Next
 
  strReturn = ""
 
  dblTotal = 0#
 
  ReDim strArray(0) As String
  ReDim strResult(0) As String
 
  For Each objCell In rngCells
 
      If IsNumeric(objCell.Value) Then
         ReDim Preserve strArray(UBound(strArray) + 1) As String
         strArray(UBound(strArray)) = objCell.Value & Chr$(0) & objCell.Address(RowAbsolute:=False, COLUMNABSOLUTE:=False)
      End If
     
  Next objCell
 
  If (blnQuick_Sort_Strings(strArray, 1&, UBound(strArray), False)) Then
     For lngLoop = UBound(strArray) To 1& Step -1&
     
         intPos = InStr(strArray(lngLoop), Chr$(0))
         
         dblValue = CDbl(Left$(strArray(lngLoop), intPos - 1))
         
         If dblTotal + dblValue <= dblFind_Total Then
            dblTotal = dblTotal + dblValue
           
            ReDim Preserve strResult(UBound(strResult) + 1) As String
            strResult(UBound(strResult)) = Mid$(strArray(lngLoop), intPos + 1)
           
            If dblValue = dblFind_Total Then
               Exit For
            End If
         End If
         
     Next lngLoop
  End If
     
  If UBound(strResult) > 0& Then
     If (blnQuick_Sort_Strings(strResult, 1&, UBound(strResult), True)) Then
        strReturn = ""
        For lngLoop = 1& To UBound(strResult)
            strReturn = strReturn & IIf(Len(strReturn) > 0, IIf(lngLoop < UBound(strResult), ", ", " and "), "") & strResult(lngLoop)
        Next lngLoop
     End If
  End If

  Find_Total = strReturn & IIf(Len(strReturn) > 0, " = " & CStr(dblTotal), "ERROR!")
 
End Function
Private Function blnQuick_Sort_Strings(ByRef strArray() As String, ByRef lngLow_Value As Long, ByRef lngHigh_Value As Long, Optional ByVal blnAlpha_Sort As Boolean = False) As Boolean

  Dim blnReturn                                         As Boolean
  Dim blnSwap                                           As Boolean
  Dim lngLow                                            As Long
  Dim lngHigh                                           As Long
  Dim lngPivot                                          As Long
  Dim lngPosLow                                         As Long
  Dim lngPosHigh                                        As Long
  Dim strPivot                                          As Variant

  On Error GoTo Err_blnQuick_Sort_Strings
   
  blnReturn = False
   
  lngLow = lngLow_Value
  lngHigh = lngHigh_Value

  If lngLow >= lngHigh Then
     blnQuick_Sort_Strings = True
     Exit Function
  End If

' If only 2 elements in this subdivision; swap them if out of order...

  If (lngHigh - lngLow) = 1& Then
     If (blnAlpha_Sort) Then
        blnSwap = (strArray(lngLow) > strArray(lngHigh))
     Else
        blnSwap = (Val(strArray(lngLow)) > Val(strArray(lngHigh)))
     End If

     If (blnSwap) Then
        Call strSwap(strArray(lngLow), strArray(lngHigh))
     End If

     blnQuick_Sort_Strings = True
     Exit Function
  End If

' Pick a pivot element at random & move it to the end...

  lngPivot = CLng(Int(Rnd(1) * (lngHigh - lngLow) + 1&) + lngLow)

  Call strSwap(strArray(lngHigh), strArray(lngPivot))
         
  strPivot = UCase$(strArray(lngHigh))

  Do

      lngPosLow = lngLow
      lngPosHigh = lngHigh

' Move in from both sides towards the pivot element...

      If (blnAlpha_Sort) Then
         Do While (lngPosLow < lngPosHigh) And (UCase$(strArray(lngPosLow)) <= strPivot)
            lngPosLow = lngPosLow + 1&
         Loop

         Do While (lngPosHigh > lngPosLow) And (UCase$(strArray(lngPosHigh)) >= strPivot)
            lngPosHigh = lngPosHigh - 1&
         Loop
      Else
         Do While (lngPosLow < lngPosHigh) And (Val(strArray(lngPosLow)) <= Val(strPivot))
            lngPosLow = lngPosLow + 1&
         Loop

         Do While (lngPosHigh > lngPosLow) And (Val(strArray(lngPosHigh)) >= Val(strPivot))
            lngPosHigh = lngPosHigh - 1&
         Loop
      End If

' If we haven't reached the pivot element then two elements on either side are out of order & need swapping...

      If lngPosLow < lngPosHigh Then
         Call strSwap(strArray(lngPosLow), strArray(lngPosHigh))
      End If

   Loop While (lngPosLow < lngPosHigh)

' Move the pivot element back to its proper place in the array...

  Call strSwap(strArray(lngPosLow), strArray(lngHigh))
         
' Recursively call the Sort procedure (pass the smaller subdivision first to use less stack space)...

  blnReturn = True
 
  If (lngPosLow - lngLow) < (lngHigh - lngPosLow) Then
     blnReturn = blnQuick_Sort_Strings(strArray(), lngLow, lngPosLow - 1&, blnAlpha_Sort)
     
     If (blnReturn) Then
         blnReturn = blnQuick_Sort_Strings(strArray(), lngPosLow + 1&, lngHigh, blnAlpha_Sort)
     End If
  Else
     blnReturn = blnQuick_Sort_Strings(strArray(), lngPosLow + 1&, lngHigh, blnAlpha_Sort)
     
     If (blnReturn) Then
        blnReturn = blnQuick_Sort_Strings(strArray(), lngLow, lngPosLow - 1&, blnAlpha_Sort)
     End If
  End If
 
Exit_blnQuick_Sort_Strings:

  On Error Resume Next
   
  blnQuick_Sort_Strings = blnReturn
   
  Exit Function
   
Err_blnQuick_Sort_Strings:

  blnReturn = False
 
  Resume Exit_blnQuick_Sort_Strings
 
End Function
Private Sub strSwap(ByRef strFirst As String, ByRef strSecond As String)

  Dim strTemp                                           As String

  On Error Resume Next

  strTemp = strSecond
  strSecond = strFirst
  strFirst = strTemp

End Sub

=== END OF CODE ===


If you place this formula in the cell where you would like the result:

="ANS: " & Find_Total(B2:B6,B8)

It will return (as requested):

ANS: B3, B4 and B5 = 42


However, if cell B3 was a value of 13, the result would be:

ANS: B3, B4 and B5 = 43

If cell B3 was 14...

ANS: B3 and B5 = 43


Hope this addresses your problem.

BFN,

fp.
[http://NigelLee.info]

Hi,

Sorry... I forgot to declare the data type of the return from the main function.

Please replace:

Public Function Find_Total(ByRef rngCells As Range, ByVal dblFind_Total As Double)

With

Public Function Find_Total(ByRef rngCells As Range, ByVal dblFind_Total As Double) As String


Not strictly necessary, but just for clarity.

Please let me know when you have tried the code, and report any feedback.

Thanks.

BFN,

fp.

I am very impressed the only problem we have is that if the cells contain the following and our required answer is £400, the results is: ANS: B2 and B3 = 350. Instead of ANS: B1 B2 and B3 = 400
       B
1    100
2    100
3    250
4    200

If I change the required answer to £450 then this gives me ANS: B3 and B4 =450. Is it also possible to make this work on non-adjacent cells? For example only use B1 B2 and B4.

I must reitterate how impressed I am with this already, I dare not imagine how long it would have taken me to try and come up with something that would come even anywhere near performing what I wanted.

Another excellent point I must make is that it was nice to be able to just paste the code across and it work first time.

Thanks

Lianne

Hi Lianne,

Thanks for your comments.  It's equally as rewarding to be appreciated! :)

Yes, I think you've found an issue I was trying to describe.

As the code just extracts one combination of cells that are equal to, or less than the desired total, the it will return "correct" results, but as above, not the "best correct" result [if that makes sense].

That is, it will return what you asked it to do, but not necessarily the best match.

What I proposed is that the code could be amended to search all combinations possible and then find the closest match to the required total (or the exact total, if possible) before reporting back into the formula cell.

Please leave this with me for a while, and I'll come back with a revised version.

How soon did you need a working solution, btw?

BFN,

fp.

Sorry... missed your query regarding non-adjacent cells.

In your example, just B1, B2, B4 could be specified as follows:

Define a "named" range.

"Insert" menu -> "Name" -> "Define..."

Type MY_RANGE into the first field, then using the cell/range selection icon to the far right at the bottom of the dialog box, select the cells you need.

For example:

MY_RANGE

.
.
.
.
.

=Sheet1!B1,Sheet1!B2,Sheet1!B4

Now click "Add", then "OK".


Edit the existing formula to now read:

=Find_Total(MY_RANGE, 450)

(or whatever)


Hope that helps.

BFN,

fp.

Hello again,

NON-ADJACENT cells - that works great. I have created a lookup range that I can just amend as my data and fields change (i.e. when I take values out of the range, after I have used your functions to get a match).

-- What I proposed is that the code could be amended to search all combinations possible and then find the closest match to the required total (or the exact total, if possible) before reporting back into the formula cell.
Sorry I misinterpreted this previously, I did want the best match if possible. There is no great rush for this as I have a number of other bits and pieces to finish on the workbook.

Thanks again

Lianne

You must be a genius!!

Thats brilliant, thanks a lot. It works a treat and does exactly what I want. Thanks for all your help.

Lianne

PS: -- * The actual "ANS:" should be B1, B2 and B4 (not ...B3 as you wrote - presumably just a typo)!
Yes, that was a typo, my maths are not quite that bad!! (I hope)

Thanks again.

You're very welcome.

Nope - not a genius... yet... but ever hopeful! :)

(and also prone to typos!)

Thanks for the grading/points.

BFN,

fp.

Thanks for your speedy responses, for the intial problem and the mods. I have posted some extra points for you at: -
https://www.experts-exchange.com/questions/20865279/Points-for-fanpages.html

Thanks again.

Lianne

That's very kind of you.

I appreciate the gesture.

Thank you :)

Happy codin'.

BFN,

fp.

i am looking for something similar to this but i do not understand how to get the macro to work.  I have a list of values in column A and I want to see which ones add up to total.  Could someone help me understand the macro.

Thansks,
Montrof

Also my list has negative numbers in it, does this function take that into consideration.