Can anyone tell me if there is a way Excel can do the following?

I need to work out which amounts are added together to make up a total amount.
eg

If I have a list of numbers i.e
1200
1000
2000
3000
1100
900
3120

And I have a total of 4100 is there a formula that can work out how many
combinations (from the list of numbers) can add up to this total?? ie
1. 1200+900+2000
or 3000+1100

There is no formula. I have a macro that I wrote years back that does this.
It returned the results listed below from your list:
1100 + 3000
900 + 1200 + 2000
1000 + 1100 + 2000

One issue with it is that it requires that a minimum of 9 elements be
selected. About once a year somebody needs it so I havn't bothered fixing it.
You can just add values larger than the target value if you have less than 9
items. Another reason is that most people don't realize how many combinations
from a relatively short list can some to a specific value. Typically they are
expected only a few. For example, I just ran it, and from a list of 30 items
it returned 561 combinations that summed to 121. It goes up exponentially and
easily gets to several thousand and beyond. What would you do with this?

If interested I can supply. Be advised it fills an entire module.

Regards,
Greg


"DJuan" wrote:

Can anyone tell me if there is a way Excel can do the following?

I need to work out which amounts are added together to make up a total amount.
eg

If I have a list of numbers i.e
1200
1000
2000
3000
1100
900
3120

And I have a total of 4100 is there a formula that can work out how many
combinations (from the list of numbers) can add up to this total?? ie
1. 1200+900+2000
or 3000+1100

I decided to fix the 9 element minimum issue in case you care. It's fixed.
Forget what I said about that.

Greg

Greg

Thanks for your replies. I would be interested in that macro if you could
send it to me at

Thanks again

Sean

"Greg Wilson" wrote:

I decided to fix the 9 element minimum issue in case you care. It's fixed.
Forget what I said about that.

Greg

You will have to create a standard code module and paste all of the below
code to this module. Then you can access the macro through Tools Macro
Macros...

Instructions:
1. Press <Alt + F11 or go through Tools Macro Visual Basic Editor
2. Select Insert in the Visual Basic Editor menu bar
3. Select Module
4. Paste all of the below code to the new module

'----------- Start code ----------

Option Explicit
Dim Abort As Boolean

Sub FindCombins()
Dim a As Long, b As Long, c As Long
Dim d As Long, e As Long, f As Long
Dim g As Long, h As Long, i As Long
Dim j As Long, x As Long, y As Long
Dim s1 As Long, s2 As Long, s3 As Long
Dim s4 As Long, s5 As Long, s6 As Long
Dim s7 As Long, s8 As Long, s9 As Long
Dim s10 As Long, col As Long
Dim Resp As Integer, Style As Integer
Dim v As Single, v0 As Single, Ar() As Double
Dim cell As Range
Dim txt As String, Title As String
Dim t1 As Date, t2 As Date

Title = "Find Combinations"
s1 = 0: s2 = 0: s3 = 0: s4 = 0: s5 = 0
s6 = 0: s7 = 0: s8 = 0: s9 = 0: s10 = 0
On Error GoTo SkipToHere

txt = "This macro will find combinations of " & _
"the current cell selection that sum to a specified " & _
"value. If the cells containing the source values " & _
"are not currently selected then press Cancel, select " & _
"thes cells and run the macro again." & vbCr & vbCr & _
"Requirements:" & vbCr & _
"- Source values must be selected before running the " & _
"macro. The selection does not need to be " & _
"contiguous." & vbCr & _
"- Select only cells containing numeric values." & vbCr & _
"- Duplicate values should be removed from the " & _
"selection." & vbCr & _
"- A maximum of 10 elements in combination that sum " & _
"to the target value is supported."

Style = vbInformation + vbOKCancel
Resp = MsgBox(txt, Style, Title)
If Resp = vbCancel Then Exit Sub

col = ActiveCell.Column
txt = vbCr & vbCr & _
"Specify the target value or select cell:"
With Application
v0 = .InputBox(txt, Title)
If v0 = 0 Then Exit Sub
.ScreenUpdating = False
End With
ReDim Ar(0 To Application.Max(Selection.Count, 9))
Ar(0) = 0
i = 0
For Each cell In Selection.Cells
i = i + 1
Ar(i) = cell.Value
Next
If i < 9 Then
x = 0
For j = i + 1 To 9
x = x + 1
Ar(j) = v0 + x
Next
End If

Ar = SortArray(Ar)
Call FindDupes(Ar)
If Abort Then Exit Sub
DoEvents
t1 = Now
ActiveCell.EntireColumn.Insert
x = 0
y = UBound(Ar)

'xxxxxxxxxxxx Start Loop xxxxxxxxxx
For a = s1 To y - 9: For b = a + s2 To y - 8
For c = b + s3 To y - 7: For d = c + s4 To y - 6
For e = d + s5 To y - 5: For f = e + s6 To y - 4
For g = f + s7 To y - 3: For h = g + s8 To y - 2
For i = h + s9 To y - 1: For j = i + s10 To y

v = Ar(a) + Ar(b) + Ar(c) + Ar(d) + Ar(e) + Ar(f) + _
Ar(g) + Ar(h) + Ar(i) + Ar(j)
If v = v0 Then
x = x + 1
txt = GetText(Ar(a), Ar(b), Ar(c), Ar(d), Ar(e), _
Ar(f), Ar(g), Ar(h), Ar(i), Ar(j))
Cells(x, col) = txt
txt = ""
ElseIf v v0 Then
Exit For
End If

s10 = 1: Next: s9 = 1: Next: s8 = 1: Next: s7 = 1 _
: Next: s6 = 1: Next
s5 = 1: Next: s4 = 1: Next: s3 = 1: Next: s2 = 1 _
: Next: s1 = 1: Next
'xxxxxxxxxxxx End Loop xxxxxxxxxxxxxx

SkipToHe
Columns(col).EntireColumn.AutoFit
t2 = Now
If x 65536 Then
txt = "Too many combinations found. Max capacity 65536. "
Style = vbExclamation
ElseIf x = 0 Then
'Columns(col).Delete
If Err.Number = 0 Then
txt = "No combinations were found equalling " & v0 & " "
Else
txt = "An error caused the macro to fail. " & vbCr & vbCr & _
"- Ensure that the selection does not include text" & vbCr & _
"- Ensure that a minimum of seven values are selected" & vbCr & _
"- Ensure that numeric values are not formated with " & _
"apostrophes"
End If
Style = vbExclamation
Else
txt = "Combinations found equalling " & v0 & " = " & x & " " & _
vbCr & vbCr & _
"Hours = " & Hour(t2 - t1) & vbCr & _
"Minutes = " & Minute(t2 - t1) & vbCr & _
"Seconds = " & Second(t2 - t1)
Style = vbOKOnly
End If
ActiveCell.Select
Application.ScreenUpdating = True
MsgBox txt, Style, Title
End Sub

Private Function GetText(a As Double, b As Double, _
c As Double, d As Double, e As Double, f As Double, _
g As Double, h As Double, i As Double, j As Double) As String
Dim Ar As Variant
Dim x As Integer
Dim t As String
Ar = Array(a, b, c, d, e, f, g, h, i, j)
For x = 9 To 0 Step -1
If Ar(x) = 0 Then Exit For
t = " + " & Ar(x) & t
Next
GetText = Right(t, Len(t) - 3)
End Function

Private Function SortArray(Ar As Variant) As Variant
Dim i As Integer, j As Integer
Dim Temp As Double
For i = LBound(Ar) To UBound(Ar) - 1
For j = (i + 1) To UBound(Ar)
If Ar(i) Ar(j) And Ar(i) < 0 Then
Temp = Ar(j)
Ar(j) = Ar(i)
Ar(i) = Temp
End If
Next j
Next i
SortArray = Ar
End Function

Private Sub FindDupes(Ar As Variant)
Dim i As Integer, ii As Integer, cnt As Integer
Dim val As Double
Dim ar2() As Variant
Dim ar3() As Variant
Dim txt As String, txt2 As String
Dim Style As Integer
Dim Resp As Integer
Dim Dupes As Boolean

Dupes = False
Abort = False
ii = 0
For i = LBound(Ar) + 1 To UBound(Ar)
If Ar(i) = Ar(i - 1) Then
Dupes = True
cnt = 0
val = Ar(i)
ReDim Preserve ar2(ii)
ReDim Preserve ar3(ii)
ar2(ii) = Ar(i)
Do Until Ar(i) < Ar(i - 1)
i = i + 1
cnt = cnt + 1
If i = UBound(Ar) Then Exit Do
Loop
ar3(ii) = cnt + 1
ii = ii + 1
End If
Next
If Not Dupes Then Exit Sub
For i = LBound(ar2) To UBound(ar2)
txt2 = txt2 & "Value: " & ar2(i) & " Repetitions: " & _
ar3(i) & vbCr
Next
txt = "Duplicate values found in selection:" & vbCr & txt2 & _
vbCr & vbCr & "The presence of duplicates will produce duplicate " & _
"results and thus slow performance and serve no purpose. You are " & _
"advised to remove the duplicate values and run the macro again." & _
vbCr & vbCr & "Continue ?"

Resp = MsgBox(txt, vbOKCancel + vbExclamation, "Find Combinations")
If Resp = vbCancel Then Abort = True
End Sub

'----------- End code ---------------