Addition function of multiple cells

  • Thread starter Thread starter DB74
  • Start date Start date
D

DB74

Does anyone know if there is a function that will take a list of numbers in
different cells and run various addition combinations on the list to detemine
which cells will add to a specific number? For example:

A1 = 1
A2 = 2
A3 = 5
A4 = 7

I want to know which cells added to gether will give me 6...answer = A1 + A3
 
Does anyone know if there is a function that will take a list of numbers in
different cells and run various addition combinations on the list to detemine
which cells will add to a specific number? For example:

A1 = 1
A2 = 2
A3 = 5
A4 = 7

I want to know which cells added to gether will give me 6...answer = A1 + A3
Click to expand...

Put the specific number, in you example 6, in cell C1.
Put the number of numbers, in your example 4, in cell C2.

Then type the following formula, all in one row, in cell B1

=IF(MID(DEC2BIN(MATCH(TRUE,MMULT(--MID(DEC2BIN(
ROW(OFFSET(A$1,,,2^C$2-1)),C$2),COLUMN(OFFSET(A$1,,,,C$2)),1),
(OFFSET(A$1,,,C$2,1)))=C$1,0),C$2),ROW(),1)="1","X","")

Copy the formula in cell B1 down as far as you have numbers in column
A, ie to cell B4 in your example.

The result will be an "X" beside all the numbers to add to get the
specific number. In cell B1 and B3 in your example.
If there is no possible combination of numbers that will add up to the
specific number, you will get #N/A besides all numbers.

Note that there might be more than one possible combination of numbers
that solves the problem, this way you will only be given at most one
combination.

Hope this helps / Lars-Åke
 
Thanks,

When I copied the formula (all in 1 row), it indicates the formula is not
valid and highlights the first OFFSET in the formula.
 
Which version of Excel do you have?
I tested the formula with your example in Excel 2007 with expected
result.

Lars-Åke
 
I am using 2003... would that make a difference?

Lars-Ã…ke Aspelin said:
Which version of Excel do you have?
I tested the formula with your example in Excel 2007 with expected
result.

Lars-Ã…ke




.
Click to expand...
 
Below is a macro called 'Combos_Range' that will list all combos for any
range you want.
--
Hope this helps.
If it does, please click the Yes button.
Thanks in advance for your feedback.
Gary Brown



Option Explicit

'/=========================================/
' Sub Purpose:
' 07/01/2008 This program will give the addition of each
' combination of cells selected within a range
' of values. The # of combinations is calculated
' as [2^(# of cells selected)] - 1
'
' Jan-12-2010 Dennis Keenan helped me figure out a bug in
' which a selection of 16 or more items did not return
' all possible values.
'
' May-25-2010 - add 'Formula' column and data
'

'/=========================================/
Sub Combos_Range()
Dim aryA()
Dim aryNum()
Dim aryExp() As String
Dim dtStartTime As Date
Dim dtEndTime As Date
Dim dblLastRow As Double, dblRow As Double
Dim dblStartRange As Double
Dim dblEndRange As Double
Dim i As Double
Dim x As Double, iMaxCount As Double
Dim iMaxRows As Double
Dim iMaxCombos As Double
Dim z As Double, R As Double
Dim y As Double
Dim iCount As Double
Dim dblOrigCalcStatus As Double
Dim iWorksheets As Integer
Dim iCol As Integer
Dim objCell As Object
Dim rngInput As Range
Dim strStartRange As String
Dim strEndRange As String
Dim strOriginalAddress As String
Dim strRngInputAddress As String
Dim strWorksheetName As String
Dim strResultsTableName As String
Dim strType As String
Dim varAnswer As Variant

On Error GoTo err_Sub

'/----------start-up Variables-------------/
strResultsTableName = "Combinations_Listing_Range"
strOriginalAddress = Selection.Address
strWorksheetName = ActiveSheet.name
iMaxCount = 21 ' max memory for my computer
iMaxRows = 65000
iMaxCombos = 2 ^ iMaxCount
'/----------end start-up Variables---------/

'get start value
strStartRange = InputBox(Prompt:= _
"Enter the Low Value for Range of Values to be " & _
"returned in Combinations " & vbCr & "or" & vbCr & _
"'OK' for default of " & _
"-999,999,999,999.99." & vbCr & vbCr, _
Title:="Combinations....START", Default:="-999999999999.99")

If Len(strStartRange) = 0 Then
GoTo exit_Sub
End If

dblStartRange = Val(strStartRange)

'get end value
strEndRange = InputBox(Prompt:= _
"Enter the High Value for Range of Values to be " & _
"returned in Combinations " & vbCr & "or" & vbCr & _
"'OK' for default of " & _
"+999,999,999,999.99." & vbCr & vbCr, _
Title:="Combinations....END", Default:="999999999999.99")

If Len(strEndRange) = 0 Then
GoTo exit_Sub
End If

dblEndRange = Val(strEndRange)

'check if start range is smaller than end range
If dblStartRange > dblEndRange Then
MsgBox "The Start value ( " & dblStartRange & _
" ) is larger than the Ending value ( " & _
dblEndRange & " ).", vbExclamation + vbOKOnly, _
"Warning... Process STOPPED!"
GoTo exit_Sub
End If

Set rngInput = _
application.InputBox(Prompt:= _
"Select Range of Numbers to be used as input for " & _
"combinations output" & vbCr & vbCr & _
"Note: Currently limited to " & _
iMaxCount & " cells or less", _
Title:="Combinations....RANGE", _
Default:=strOriginalAddress, Type:=8)

'get how many cells have been selected and location
iCount = rngInput.Count
strRngInputAddress = rngInput.Address

Select Case iCount
'check if # of cells selected is ok
Case 0
MsgBox "No cells have been selected." & vbCr & _
vbCr & "Process aborted...", _
vbExclamation + vbOKOnly, _
"Warning..."
GoTo exit_Sub
Case 1 To iMaxCount
i = (2 ^ iCount) - 1
varAnswer = MsgBox("The " & iCount & _
" selected cell(s) will produce and review " & _
application.WorksheetFunction.Text(i, "#,##") & _
" combinations." & vbCr & "Do you wish to continue?", _
vbInformation + vbYesNo, _
"Combinations...")
If varAnswer = vbNo Then Exit Sub
Case Is > iMaxCount
varAnswer = _
MsgBox("Only the first " & iMaxCount & _
" cells in the range <<< " & _
strRngInputAddress & " >>> will be processed." & vbCr & _
vbCr & "Continue?", vbExclamation + vbYesNo, "Warning")
If varAnswer = vbNo Then Exit Sub
End Select

If iCount > iMaxCount Then iCount = iMaxCount

'now that we can calculate the actual dimensions
' we can re-dimension the arrays
ReDim aryNum(1 To iCount, 1 To 2) 'value / address
ReDim aryA(1 To iMaxCombos, 1 To 3) 'value, string and address
ReDim aryExp(1 To iCount) 'formatted value

'populate the array with the values in the selected cells
i = 0
For Each objCell In rngInput
'check to see if all selected values are numbers
Select Case VarType(objCell)
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, _
vbDecimal, vbByte, vbDate
strType = "Number"
Case Else
strType = "Other"
End Select

If strType <> "Number" Then
MsgBox _
"Only Numbers may be selected for this process." & _
vbCr & vbCr & _
Chr(34) & objCell.Value & Chr(34) & " in Cell " & _
objCell.Address & _
" is not valid. Process has stopped.", _
vbInformation + vbOKOnly, "Warning..."
GoTo exit_Sub
End If

'put numbers in array
i = i + 1
If i > iMaxCount Then Exit For
aryNum(i, 1) = objCell.Value2
aryNum(i, 2) = objCell.Address
aryExp(i) = _
application.WorksheetFunction.Text(objCell.Value, "@")
Next objCell

'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count

'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count
For x = 1 To i
If UCase(Worksheets(x).name) = _
UCase(strResultsTableName) Then
Worksheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
application.DisplayAlerts = True
Exit For
End If
Next

'Add new worksheet at end of workbook
' where results will be located
Worksheets.Add.Move After:=Worksheets(ActiveSheet.name)

'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.name = strResultsTableName
ActiveWorkbook.ActiveSheet.Range("A1").Value = "Amount"
ActiveWorkbook.ActiveSheet.Range("B1").Value = "Combo"
ActiveWorkbook.ActiveSheet.Range("C1").Value = "Formula"
Range("A1:C1").Font.Bold = True

On Error Resume Next
Range("A2").Select

'initialize variable to desired values
z = 1
y = 1
dblRow = 2
iCol = 1

'add the first element
aryA(y, 1) = aryNum(z, 1)
aryA(y, 2) = "'" & Format(aryExp(z), "#,##0.00")
aryA(y, 3) = "'+" & aryNum(z, 2)

'initialize arrays with combos
For z = 2 To iCount
y = y + 1
aryA(y, 1) = aryNum(z, 1)
aryA(y, 2) = "'" & Format(aryExp(z), "#,##0.00")
aryA(y, 3) = "'+" & aryNum(z, 2)
For x = 1 To ((2 ^ (z - 1)) - 1)
y = y + 1
aryA(y, 1) = aryA(x, 1) + aryNum(z, 1)
aryA(y, 2) = aryA(x, 2) & " + " & _
Format(aryExp(z), "#,##0.00")
aryA(y, 3) = aryA(x, 3) & " + " & aryNum(z, 2)
Next x
Next z

'put array info into worksheet
For R = 1 To y
If dblStartRange <= aryA(R, 1) And _
dblEndRange >= aryA(R, 1) Then
Cells(dblRow, iCol) = aryA(R, 1)
Cells(dblRow, iCol + 1) = aryA(R, 2)
Cells(dblRow, iCol + 2) = aryA(R, 3)
dblRow = dblRow + 1
If dblRow >= iMaxRows Then
dblRow = 2
iCol = iCol + 4
End If
End If
Next R

'format worksheet
Cells.Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("A2"), _
Order1:=xlAscending, HEADER:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
ActiveWindow.Zoom = 75

Range("A1:C1").Select

With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Font.Underline = xlUnderlineStyleSingle
End With

Columns("A:A").NumberFormat = _
"_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
Columns("A:C").EntireColumn.AutoFit
If Columns("B:B").ColumnWidth > 75 Then
Selection.ColumnWidth = 75
End If
If Columns("C:C").ColumnWidth > 75 Then
Selection.ColumnWidth = 75
End If
Selection.HorizontalAlignment = xlLeft

Rows("1:1").Select
Selection.Insert Shift:=xlDown
dblLastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
dblLastRow = dblLastRow + 1

'adjust info for max # of processed cells
If iCount > iMaxRows Then iCount = iMaxRows

application.ActiveCell.Formula = "=Text(SUBTOTAL(3,A3:A" & _
dblLastRow + 10 & ")," & Chr(34) & "#,##0" & _
Chr(34) & ") & " & _
Chr(34) & " Combinations found for " & _
application.WorksheetFunction.Text(iCount, "#,##") & _
" selections in range: " & _
strRngInputAddress & " - with Range: " & _
Format(dblStartRange, "#,##0.00") & " to " & _
Format(dblEndRange, "#,##0.00") & Chr(34)
Selection.Font.Bold = True

Cells.Select
With Selection.Font
.name = "Tahoma"
.Size = 10
End With

Range("A3").Select
ActiveWindow.FreezePanes = True

application.Dialogs(xlDialogWorkbookName).Show

exit_Sub:
On Error Resume Next
Set rngInput = Nothing
Exit Sub

err_Sub:
Debug.Print "Error: " & Err.Number & " - (" & _
Err.Description & _
") - Sub: Combos_Range - Module: " & _
"Mod_Combinations_List_All - " & Now()
GoTo exit_Sub

End Sub
'/================================/
 
I don't think so, but I have only tested the formula in Excel 2007, so
I am not sure.

Lars-Åke
 
DB74

you can use Tom Hutchins code, i already try and succeed...
@ Tom, hope its ok if i give this code to others... thanks tom
you can read in this link
http://www.microsoft.com/communitie...e528337714eb&lang=en&cr=US&sloc=en-us&m=1&p=1


To run the macro, select the range of 4 numbers (A1-A4). Then press Alt-F8
to bring up a list of available macros. Select Knapsack >> OK. The macro will
prompt you for a target number. Enter 6 and click OK.

'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
Public Kount As Currency, RngCnt As Long, strTarget As String
Public Soln() As RngType, SolnCnt As Long
Public 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
Dim 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", , "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&) > Rows.Count Then
MsgBox "Can't fit all the solutions on the sheet", , "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.", ,
"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

Put the code in a general VBA module in your workbook. If you are
new to macros, this link to Jon Peltier's site may be helpful:
http://peltiertech.com/WordPress/2008/03/09/how-to-use-someone-elses-macro/

Some of the lines may wrap from being posted in the forum. The visiual basic
editor will color these red until you fix (unwrap) them.
 
I tried the formula in 07 and it worked and then saved the file and tried to
open it in 03. I received a msg indicating the formula had too many nested
statements for 03. Any chance you can modify the formula so that it does not
have more than the max of 7 nested statements?

Thanks.
 
If you can accept "1" and "0" instead of "X" and "blank"
(you can always have this in a hidden helper column and translate "1"
to "X" and "0" to "blank" with a second formula) try this formula that
is limited to 7 levels of nesting:

=MID(DEC2BIN(MATCH(TRUE,MMULT(--MID(DEC2BIN(ROW(A$1:A$15),C$2),COLUMN(OFFSET(A$1,,,,C$2)),1),OFFSET(A$1,,,C$2,1))=C$1,0),C$2),ROW(),1)

Note that it is no longer sufficient to just change cell C2 to reflect
a changed number of numbers in the A column.
You also have to manually modify the formula to suit the number of
numbers that you have.
In the formula above, replace the 15 with 2^n-1 where n is the number
of numbers.

Hope this helps / Lars-Åke
 
Back
Top