find combination of cells that equals a sum

[Billy Rogers]

A friend asked me this

"Would there by chance be a function in Excel where you can choose a range
of cells with an amount in each cell and see if any combination of those
cells added up to a certain dollar amount? Say, I have a range of data that
adds up to $1,536,211.26, but I'm trying to see if any of the cells in that
range add up to $12,455.98."

Have any of you guys ever done something like this? I think it may have to
be solved using VBA.

thanks



--
Billy Rogers

Dallas,TX

Currently Using SQL Server 2000, Office 2000 and Office 2003

http://thedataguru.blogspot.com/

 

[Joel]

I have do things like this before. It requires a recursive program because
the totals may be 1 to or three or more items

If you have an array of 5 items 1 - 5 then you want to check (number below
reffer to the index of the array)

1
2
3
4
5
1 + 2
1 + 3
1 + 4
1 + 5
2 + 3
2 + 4
2 + 5
etc, etc, etc

here is some code to get you started. All you need to do is to put the
range of cells into the array Instrings.

Public InStrings
Public combo
Public RowCount
Public ComboLen
Sub combinations()

InStrings = Array(1, 2, 3, 4, 5, 6)
Length = UBound(InStrings) + 1

Level = 1
RowCount = 1
For ComboLen = 1 To Length
ReDim combo(ComboLen)
Position = 0

Call recursive(Level, Position)
Next ComboLen
End Sub
Sub recursive(ByVal Level As Integer, ByVal Position As Integer)

Length = UBound(InStrings) + 1

For i = Position To (Length - 1)

'for combinations check if item already entered
found = False
For j = 0 To (Level - 2)
'combo is a count of the combinations,not the actual data
'123
'124
'125
'234
'235
'245
'345
'data is actually in InStrings
If combo(j) = i Then
found = True
Exit For
End If
Next j

If found = False Then
combo(Level - 1) = i
If Level = ComboLen Then
For j = 0 To (ComboLen - 1)
If j = 0 Then
ComboString = InStrings(combo(j))
Mytotal = Val(InStrings(combo(j)))
Else
ComboString = ComboString & "," & InStrings(combo(j))
Mytotal = Mytotal + Val(InStrings(combo(j)))
End If
Next j
Sheets("Sheet2").Range("A" & RowCount) = ComboString
Sheets("Sheet2").Range("B" & RowCount) = Mytotal
RowCount = RowCount + 1
Else
Call recursive(Level + 1, i)
End If
End If
Next i
End Sub

 

[Jim Thomlinson]

Here is some code from Harlan Grove... Note that you need a reference to
Microsoft Scripting Runtime and Microsoft VBScript Regular Expressions 1.0

In the VBE Tools -> Refences Check the appropriate reference

Also not that this is good for a list of about 30 or so items. The
permiutations and combinations of get to be just too much beyond that...

Option Explicit
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0
'Written by Harlan Grove

Sub FindSums()
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 ----

 

[Gary''s Student]

Use Solver:

http://www.tushar-mehta.com/excel/templates/match_values/index.html#Solver_Template

 

[Billy Rogers]

Thanks for the help!
--
Billy Rogers

Dallas,TX

Currently Using SQL Server 2000, Office 2000 and Office 2003

http://thedataguru.blogspot.com/

 

[SteveM]

Thanks for the help!
--
Billy Rogers

Dallas,TX

Currently Using SQL Server 2000, Office 2000 and Office 2003

http://thedataguru.blogspot.com/

Solver's the best solution but the formulation on the link is the most
basic. It will report an infeasible solution if no combination of
values provides an exact equality. Better to Minimize the sum of the
deviations from the Target Value and if the solution is exact great,
if not, it tells you the best solution that gets you the closest.

The simplest extension is

Sum Xi - Target Value

But since you want to include both the negative and positive deviation
you can also run

Tanget Value - Sum Xi

And select the smallest difference.

Or really do it right, define an axillary variable Y and break into
its positive and negative components i.e.,

So Sum Xi + Y = Target Value

Y = Y' - Y'' so

Sum Xi + Y' - Y'' = Target Value

Then minimize on the auxillary variables with the single contraint
being an equality that is set to the target value and formulate this
way:

Min Y' + Y''

subject to

Sum Xi - Y' - Y'' = Target Value

SteveM

 

[SteveM]

Solver's the best solution but the formulation on the link is the most
basic. It will report an infeasible solution if no combination of
values provides an exact equality. Better to Minimize the sum of the
deviations from the Target Value and if the solution is exact great,
if not, it tells you the best solution that gets you the closest.

The simplest extension is

Sum Xi - Target Value

But since you want to include both the negative and positive deviation
you can also run

Tanget Value - Sum Xi

And select the smallest difference.

Or really do it right, define an axillary variable Y and break into
its positive and negative components i.e.,

So Sum Xi + Y = Target Value

Y = Y' - Y'' so

Sum Xi + Y' - Y'' = Target Value

Then minimize on the auxillary variables with the single contraint
being an equality that is set to the target value and formulate this
way:

Min Y' + Y''

subject to

Sum Xi - Y' - Y'' = Target Value

SteveM

Sorry, this:

Sum Xi - Y' - Y'' = Target Value should be this:

Sum Xi + Y' - Y'' = Target Value

 

[ryguy7272]

These three macros are pretty useful:
First gives you a range of continuous numbers that sum up to a certain
number fo your choosing. Second and third calculate combinations.


First macro:
Sub FindSeries()
Dim StartRng As Range
Dim EndRng As Range
Dim Answer As Long
Dim TestTotal As Long

Answer = Range("B1") '<<< CHANGE

Set StartRng = Range("A1")
Set EndRng = StartRng
Do Until False
TestTotal = Application.Sum(Range(StartRng, EndRng))
If TestTotal = Answer Then
Range(StartRng, EndRng).Select
Exit Do
ElseIf TestTotal > Answer Then
Set StartRng = StartRng(2, 1)
Set EndRng = StartRng
Else
Set EndRng = EndRng(2, 1)
If EndRng.Value = vbNullString Then
MsgBox "No series found"
Exit Do
End If
End If
Loop
End Sub


Second macro:
Sub Matrix()
Dim mySize As Integer

mySize = Application.InputBox("What n do you want to do?", _
"Matrix Creation", , , , , , 1)
MakeMatrix mySize
End Sub

Sub MakeMatrix(n As Integer)
Dim i As Integer
Dim j As Integer
Dim myRow As Long
Dim myCol As Integer
Dim myCell As Range
Dim NotDone As Boolean
Dim myMax As Integer
Dim myMaxC As Integer

Set myCell = ActiveCell

'Create First 2 Rows
For myCol = 1 To n
myCell(1, myCol).Value = 1
myCell(2, myCol).Value = 1
Next myCol
myCell(2, n).Value = 2

myRow = 2
NotDone = False

For myCol = 1 To n - 1
If myCell(myRow, myCol).Value <> _
myCell(myRow, myCol + 1).Value - 1 Then
NotDone = True
End If
Next myCol

While NotDone

myCell(myRow, 1).Resize(1, n).Copy myCell(myRow + 1, 1)
myRow = myRow + 1

myMax = Application.Max(myCell(myRow, 1).Resize(1, n))
myMaxC = Application.CountIf(myCell(myRow, 1).Resize(1, n), myMax)

If myMaxC = 1 And myCell(myRow, n).Value = myMax Then
For i = n - 1 To 2 Step -1
If myCell(myRow, i).Value < myCell(myRow, i + 1).Value - 1 Then
myCell(myRow, i).Value = myCell(myRow, i).Value + 1
For j = i + 1 To n
myCell(myRow, j).Value = 1
Next j
GoTo Changed:
End If

If myCell(myRow, i).Value = myCell(myRow, i - 1).Value Then
myCell(myRow, i).Value = myCell(myRow, i).Value + 1
For j = i + 1 To n
myCell(myRow, j).Value = 1
Next j
GoTo Changed:
End If
Next i
End If

If myCell(myRow, n).Value <> myMax And myMaxC = 1 Then
myCell(myRow, n).Value = myCell(myRow, n).Value + 1
GoTo Changed:
End If

If myCell(myRow, n).Value <> myMax Then
myCell(myRow, n).Value = myCell(myRow, n).Value + 1
GoTo Changed:
End If

If myCell(myRow, n).Value = myMax And myMaxC <> 1 Then
myCell(myRow, n).Value = myCell(myRow, n).Value + 1
GoTo Changed:
End If

If myCell(myRow, n).Value = myMax And myMaxC = 1 Then
myCell(myRow, n - 1).Value = myCell(myRow, n - 1).Value + 1
myCell(myRow, n).Value = 1
GoTo Changed:
End If

Changed:

'Check Again
NotDone = False
For myCol = 1 To n - 1
If myCell(myRow, myCol).Value <> _
myCell(myRow, myCol + 1).Value - 1 Then
NotDone = True
End If
Next myCol

Wend

End Sub



Third macro:
Sub combinations()
Dim i As Integer
Dim A(1 To 5) As Integer
Dim B As Variant

For i = 1 To 5
A(i) = i
Next i
B = Array("A", "B", "C")

MsgBox ListSubsets(B)
'Range("A1") = ListSubsets(B)


End Sub



Regards,
Ryan---