Here is another solution (my own), which can find multiple combinations of
numbers which equal the target number. To use it:
1. Copy & paste all the code below into a VBA module in your workbook. Some
of the lines may have wrapped/split because of viewing in the newsgroup; you
will have to fix those.
2. Select the numbers in the list (the 75-100 numbers).
3. Run the Knapsack macro (Tools >> Macro >> Macros >> Knapsack). The macro
will prompt you for the target number.
4. The macro will recursively search for solutions. Any solutions it finds
will be listed on a new sheet in the workbook. It will tell you when it is
finished.
'Global variables for Knapsack
Public Type RngType
Nbr As Double 'Number in cell
Addr As String 'Address of cell
End Type
Public Cellz() As RngType, Targett As Double, Kount As Currency, RngCnt As
Long, strTarget As String
Public Soln() As RngType, SolnCnt As Long, SolnNbr As Long, SolnRow As Long
Sub Knapsack()
'Calls function KS to find combinations of values within the selection that
total the target number.
'Current LIMITS: only finds target numbers which are positive numbers; can
find multiple solutions,
'but not necessarily every possible solution. Also, if the target is the sum
of the only two numbers in the
'selection which are smaller than the target, it may not find the solution.
Dim c As Range, aa As Long, bb As Long, msg101 As String, Temp() As
RngType, NegFlag As Boolean, BigFlag As Boolean
On Error GoTo KSerr1
'Check if the selected range has > 2 cells.
If Selection.Count < 3 Then
MsgBox "You must select more than 2 cells", vbExclamation, "Are you
kidding?"
Exit Sub
End If
'Get the target number from the user.
strTarget$ = InputBox("Enter the target amount")
If Len(strTarget$) = 0 Then Exit Sub
Targett# = CDbl(strTarget$)
'Load range to be checked into Cellz array. Store the address & value from
each cell in the selected range.
RngCnt& = -1
For Each c In Selection
RngCnt& = RngCnt& + 1
ReDim Preserve Temp(RngCnt&)
Temp(RngCnt&).Addr = c.Address
Temp(RngCnt&).Nbr = c.Value
Next c
'Add one more dummy element to Cellz() to make sure last cell gets tested.
RngCnt& = RngCnt& + 1
ReDim Preserve Cellz(RngCnt&)
Cellz(RngCnt&).Addr = Cellz(RngCnt& - 1).Addr
Cellz(RngCnt&).Nbr = 0
'See if there are any negative numbers or numbers larger than Targett# in
Temp().
BigFlag = False
NegFlag = False
For aa& = 0 To (RngCnt& - 1)
If Temp(aa&).Nbr < 0 Then
NegFlag = True
ElseIf Temp(aa&).Nbr > Targett# Then
BigFlag = True
End If
Next aa&
'If both NegFlag and BigFlag are True (or False), copy all elements of
Temp() to Cellz().
'If Negflag is False but BigFlag is True, copy only elements that are
smaller than Targett#.
bb& = RngCnt& - 1
RngCnt& = -1
For aa& = 0 To bb&
If (BigFlag = True) And (NegFlag = False) Then
If (Temp(aa&).Nbr <= Targett#) And (Temp(aa&).Nbr <> 0) Then
RngCnt& = RngCnt& + 1
ReDim Preserve Cellz(RngCnt&)
Cellz(RngCnt&).Addr = Temp(aa&).Addr
Cellz(RngCnt&).Nbr = Temp(aa&).Nbr
End If
Else
If Temp(aa&).Nbr <> 0 Then
RngCnt& = RngCnt& + 1
ReDim Preserve Cellz(RngCnt&)
Cellz(RngCnt&).Addr = Temp(aa&).Addr
Cellz(RngCnt&).Nbr = Temp(aa&).Nbr
End If
End If
Next aa&
'Add one more dummy element to Cellz() to make sure last cell gets tested.
RngCnt& = RngCnt& + 1
ReDim Preserve Cellz(RngCnt&)
Cellz(RngCnt&).Addr = Temp(RngCnt& - 1).Addr
Cellz(RngCnt&).Nbr = 0
'Set Kount@ and SolnNbr& to zero.
Kount@ = 0
SolnNbr& = 0
'First call to KS() starts the chain of recursive calls. The For..Next loop
starts a new chain every time
'the previous chain returns a solution or False (no solution). Each new
chain starts one element farther in
'Cellz(), to ensure that a different solution, if any, will be found.
However, this means that the first
'element in Cellz() can only be in 1 solution, the 2nd element can only be
in 2 solutions, etc. So, we are
'still not finding every possible solution.
For bb& = 0 To (RngCnt& - 1)
SolnCnt& = -1
If KS(Cellz(bb&).Nbr, bb& + 1) Then
SolnNbr& = SolnNbr& + 1
SolnCnt& = SolnCnt& + 1
ReDim Preserve Soln(SolnCnt&)
Soln(SolnCnt&).Addr = Cellz(bb&).Addr
Soln(SolnCnt&).Nbr = Cellz(bb&).Nbr
'Add a new worksheet to the current workbook at the end.
If SolnNbr& = 1 Then
Worksheets.Add.Move After:=Worksheets(Worksheets.Count)
SolnRow& = 1
Else
'Find the last row with data in column A.
Cells(65535, 1).Select
Selection.End(xlUp).Select
Selection.Offset(4, 0).Select
SolnRow& = Selection.Row
End If
'Stop before hitting the last row of the worksheet & abending.
If (SolnCnt& + SolnRow&) > 65500 Then
MsgBox "Can't fit all the solutions on the sheet",
vbExclamation, "Error"
Exit Sub
End If
'List the elements in Soln(), which make up the solution.
For aa& = 1 To SolnCnt&
ActiveSheet.Cells(aa& + SolnRow& + 2, 1).Value =
Soln(aa&).Addr
ActiveSheet.Cells(aa& + SolnRow& + 2, 2).Value = Soln(aa&).Nbr
'Add some headings also.
Cells(SolnRow&, 1).Value = Targett#
Cells(SolnRow&, 2).Value = " = Target"
Cells(SolnRow& + 2, 1).Value = "Cell"
Cells(SolnRow& + 2, 2).Value = "Value"
Next aa&
End If
'Clear the array before the next iteration.
ReDim Soln(0)
Next bb&
'Find the last row with data in column A. 4 rows down, summarize the results.
If SolnNbr& > 0 Then
Cells(65535, 1).Select
Selection.End(xlUp).Select
Selection.Offset(4, 0).Select
Selection.Value = SolnNbr& & " solutions were found. KS function was
called " & Kount@ & " times."
End If
'Tell user we are done. Summarize results.
MsgBox SolnNbr& & " solutions were found. KS function was called " &
Kount@ & " times.", vbInformation, "Done!"
Exit Sub
KSerr1:
If Err.Number <> 0 Then
msg101$ = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox msg101$, , "Knapsack error", Err.HelpFile, Err.HelpContext
End If
End Sub
Public Function KS(yy As Double, xx As Long) As Boolean
'My own recursive and iterative algorithm for the classic knapsack
programming problem.
'yy& is the cumulative total tested against the target number in this call,
and passed to the next call
'increased by the next element of Cellz().
Dim nn As Long
'Call DoEvents so the screen can refresh, etc.
DoEvents
'Add 1 to Kount every time function is called.
Kount@ = Kount@ + 1
'Start a loop to test all remaining values of Cellz[xx] from this point in
the solution chain.
nn& = xx&
Do While nn& <= RngCnt&
If (yy# = Targett#) Then
'Found a solution in this call! Increase Soln() and save info about the last
element of Cellz() that was
'tried (nn&, which should always be the same as xx& at this point in the
function).
SolnCnt& = SolnCnt& + 1
ReDim Preserve Soln(SolnCnt&)
Soln(SolnCnt&).Addr = Cellz(nn&).Addr
Soln(SolnCnt&).Nbr = Cellz(nn&).Nbr
'Return True to the calling function.
KS = True
Exit Function
ElseIf (yy# > Targett#) Then
'yy& in this call exceeds the target number. Return False to the calling
function.
KS = False
Exit Function
'yy& is still less than the target number. Call KS() again, adding the next
element in Cellz() to yy&
ElseIf (KS(yy# + Cellz(nn&).Nbr, nn& + 1)) Then
'The call to another element of Cellz() found a successful chain. Info about
that element of Cellz()
'has already been saved in Soln(). Now increase Soln() and store information
about the Cellz() element
'in this call that is one link earlier in the solution chain.
SolnCnt& = SolnCnt& + 1
ReDim Preserve Soln(SolnCnt&)
Soln(SolnCnt&).Addr = Cellz(nn&).Addr
Soln(SolnCnt&).Nbr = Cellz(nn&).Nbr
'Return True to the calling function.
KS = True
Exit Function
End If
nn& = nn& + 1
Loop
KS = False
End Function
Hope this helps,
Hutch