Subset Sum in Excel

Question

Subset Sum in Excel

Anonymous

I am trying to make a formula that will take a column of numbers and tell me which ones will add up to a certain number. I think this will speed up bank reconciliations. The solver takes way too long and is limited to the number of entries that can be used. I believe that sumif and possibly sumproduct will do this.

Locked Question. This question was migrated from the Microsoft Support Community. You can vote on whether it's helpful, but you can't add comments or replies or follow the question.

0 comments

Answer accepted by question author

7 additional answers

Answer 1

I am trying to make a formula that will take a column of numbers and tell me which ones will add up to a certain number. I think this will speed up bank reconciliations. The solver takes way too long and is limited to the number of entries that can be used. I believe that sumif and possibly sumproduct will do this.

How about some VBA code?

Tushar Mehta's site has a Function.

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

Gord

Answer 2

Anonymous

This can be done with the Solver add-in but there is no unique solution to most such problems.

Here is a site that talks about this:

http://office.microsoft.com/en-us/excel-help/define-and-solve-a-problem-by-using-solver-HP010342416.aspx

0 comments

Answer 3

I looked at that link but I am unsure of how to apply that.

Hi,

The chance of getting a reliable solution will depend on the complexity of the data and it doesn't need to be very complex before it can all go wrong. For example say we have the numbers 1 to 12 and we're trying to solve for 12 there are 12 unique solutions; below. Here's some code originally posted by Harlan Grove. To use it paste the code into a general module and run it. When it runs you are asked to select the data range and then the number to solve for. All solutions are generated on a new worksheet.

Note the comment about references at the start of the code. You set these references in VB editor using TOOLS - REFERENCES.

12
+7+5
+8+4
+9+3
+10+2
+11+1
+5+4+3
+7+4+1
+7+3+2
+8+3+1
+9+2+1
+5+4+2+1<br><br><br> <br><br><br><br><br> <br><br><br><br><br>Sub findsums() <br><br> 'This REQUIRES VBAProject references to <br><br> 'Microsoft Scripting Runtime <br><br> 'Microsoft VBScript Regular Expressions 1.0 or higher <br><br> <br><br>Const TOL As Double = 0.000001 'modify as needed <br><br> Dim c As Variant <br><br> <br><br>Dim j As Long, k As Long, N As Long, p As Boolean <br><br> Dim s As String, t As Double, u As Double <br><br> Dim v As Variant, x As Variant, y As Variant <br><br> Dim dc1 As New Dictionary, dc2 As New Dictionary <br><br> Dim dcn As Dictionary, dco As Dictionary <br><br> Dim RE As New RegExp <br><br> <br><br>RE.Global = True <br><br> RE.IgnoreCase = True <br><br> <br><br>On Error Resume Next <br><br> <br><br>Set x = Application.InputBox( _ <br><br> Prompt:="Enter range of values:", _ <br><br> Title:="findsums", _ <br><br> Default:="", _ <br><br> Type:=8 _ <br><br> ) <br><br> <br><br>If x Is Nothing Then <br><br> Err.Clear <br><br> Exit Sub <br><br> End If <br><br> <br><br>y = Application.InputBox( _ <br><br> Prompt:="Enter target value:", _ <br><br> Title:="findsums", _ <br><br> Default:="", _ <br><br> Type:=1 _ <br><br> ) <br><br> <br><br>If VarType(y) = vbBoolean Then <br><br> Exit Sub <br><br> Else <br><br> t = y <br><br> End If <br><br> <br><br>On Error GoTo 0 <br><br> <br><br>Set dco = dc1 <br><br> Set dcn = dc2 <br><br> <br><br>Call recsoln <br><br> <br><br>For Each y In x.Value2 <br><br> If VarType(y) = vbDouble Then <br><br> If Abs(t - y) < TOL Then <br><br> recsoln "+" & Format(y) <br><br> <br><br>ElseIf dco.Exists(y) Then <br><br> dco(y) = dco(y) + 1 <br><br> <br><br>ElseIf y < t - TOL Then <br><br> dco.Add Key:=y, Item:=1 <br><br> <br><br>c = CDec(c + 1) <br><br> Application.StatusBar = "[1] " & Format(c) <br><br> <br><br>End If <br><br> <br><br>End If <br><br> Next y <br><br> <br><br>N = dco.Count <br><br> <br><br>ReDim v(1 To N, 1 To 3) <br><br> <br><br>For k = 1 To N <br><br> v(k, 1) = dco.Keys(k - 1) <br><br> v(k, 2) = dco.Items(k - 1) <br><br> Next k <br><br> <br><br>qsortd v, 1, N <br><br> <br><br>For k = N To 1 Step -1 <br><br> v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = N, N, k + 1), 3) <br><br> If v(k, 3) > t Then dcn.Add Key:="+" & _ <br><br> Format(v(k, 1)), Item:=v(k, 1) <br><br> Next k <br><br> <br><br>On Error GoTo CleanUp <br><br> Application.EnableEvents = False <br><br> Application.Calculation = xlCalculationManual <br><br> <br><br>For k = 2 To N <br><br> dco.RemoveAll <br><br> swapo dco, dcn <br><br> <br><br>For Each y In dco.Keys <br><br> p = False <br><br> <br><br>For j = 1 To N <br><br> If v(j, 3) < t - dco(y) - TOL Then Exit For <br><br> x = v(j, 1) <br><br> s = "+" & Format(x) <br><br> If Right(y, Len(s)) = s Then p = True <br><br> If p Then <br><br> RE.Pattern = "" & s & "(?=(+	$))" <br><br> If RE.Execute(y).Count < v(j, 2) Then <br><br> u = dco(y) + x <br><br> If Abs(t - u) < TOL Then <br><br> recsoln y & s <br><br> ElseIf u < t - TOL Then <br><br> dcn.Add Key:=y & s, Item:=u <br><br> c = CDec(c + 1) <br><br> Application.StatusBar = "[" & Format(k) & "] " & _ <br><br> Format(c) <br><br> End If <br><br> End If <br><br> End If <br><br> Next j <br><br> Next y <br><br> <br><br>If dcn.Count = 0 Then Exit For <br><br> Next k <br><br> <br><br>If (recsoln() = 0) Then _ <br><br> MsgBox Prompt:="all combinations exhausted", _ <br><br> Title:="No Solution" <br><br> <br><br>CleanUp: <br><br> Application.EnableEvents = True <br><br> Application.Calculation = xlCalculationAutomatic <br><br> Application.StatusBar = False <br><br> <br><br>End Sub <br><br> <br><br>Private Function recsoln(Optional s As String) <br><br> Const OUTPUTWSN As String = "findsums solutions" 'modify to taste <br><br> <br><br>Static r As Range <br><br> Dim ws As Worksheet <br><br> <br><br>If s = "" And r Is Nothing Then <br><br> On Error Resume Next <br><br> Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN) <br><br> If ws Is Nothing Then <br><br> Err.Clear <br><br> Application.ScreenUpdating = False <br><br> Set ws = ActiveSheet <br><br> Set r = Worksheets.Add.Range("A1") <br><br> r.Parent.Name = OUTPUTWSN <br><br> ws.Activate <br><br> Application.ScreenUpdating = False <br><br> Else <br><br> ws.Cells.Clear <br><br> Set r = ws.Range("A1") <br><br> End If <br><br> recsoln = 0 <br><br> ElseIf s = "" Then <br><br> recsoln = r.Row - 1 <br><br> Set r = Nothing <br><br> Else <br><br> r.Value = s <br><br> Set r = r.Offset(1, 0) <br><br> recsoln = r.Row - 1 <br><br> End If <br><br> End Function <br><br> <br><br>Private Sub qsortd(v As Variant, lft As Long, rgt As Long) <br><br> 'ad hoc quicksort subroutine <br><br> 'translated from Aho, Weinberger & Kernighan, <br><br> '"The Awk Programming Language", page 161 <br><br> <br><br>Dim j As Long, pvt As Long <br><br> <br><br>If (lft >= rgt) Then Exit Sub <br><br> swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd) <br><br> pvt = lft <br><br> For j = lft + 1 To rgt <br><br> If v(j, 1) > v(lft, 1) Then <br><br> pvt = pvt + 1 <br><br> swap2 v, pvt, j <br><br> End If <br><br> Next j <br><br> <br><br>swap2 v, lft, pvt <br><br> <br><br>qsortd v, lft, pvt - 1 <br><br> qsortd v, pvt + 1, rgt <br><br> End Sub <br><br> <br><br>Private Sub swap2(v As Variant, i As Long, j As Long) <br><br> 'modified version of the swap procedure from <br><br> 'translated from Aho, Weinberger & Kernighan, <br><br> '"The Awk Programming Language", page 161 <br><br> <br><br>Dim t As Variant, k As Long <br><br> <br><br>For k = LBound(v, 2) To UBound(v, 2) <br><br> t = v(i, k) <br><br> v(i, k) = v(j, k) <br><br> v(j, k) = t <br><br> Next k <br><br> End Sub <br><br> <br><br>Private Sub swapo(a As Object, b As Object) <br><br> Dim t As Object <br><br> <br><br>Set t = a <br><br> Set a = b <br><br> Set b = t <br><br> End Sub

Answer 4

First make a copy of your workbook to test with. With that workbook open, press [Alt]+[F11] to open the Visual Basic Editor (VBE). Copy all of the code from the Tushar-Mehta page and paste it into the code module presented to you:

Double-check and if there are two

Option Explicit

Statements at the top in your workbook, delete one of them.

Close the VBE by pressing [Alt]+[Q] or using its red-x.

Save the workbook as a "macro enabled" workbook, type .xlsm or .xlsb

Now, you need all of the values to be considered for a solution in a single row, beginning at row 3 on a sheet. You need the cells in the 1st 2 rows of that column for your own input. Let us say this is all happening in column E.

In E1 enter a number to tell the code how many possible solutions to return. In E2 enter a the amount that is to be reconciled. Select all of the cells, from E1 to the very end of the list and press [Alt]+[F8] to show the list of available macros to run, choose the startSearch macro from the list and click the [Run] button.

You will get a bunch of results (depending on how many you requested, showing the relative item numbers in the list of values make up a possible solution. This will be in the column immediately to the right of the column with the numbers in it; so it would be in column F.

Here's how mine looked after using his test data. Call this a "proof of concept". If it looks like it would be something you could use, we could modify the code a bit to get rid of the extra info (target amount, time entries) and actually return the values involved instead of their relative position, and even color the cells that make up a solution (it'll be a bit tough where 1 cell is used in more than one solution, but we'll worry with that if we ever get there)

Number of solutions desired	6	500, 11:11:06, 1, 2
Amount to match	500	500, 11:11:06, 1, 4, 5
values available for matching	-100	500, 11:11:06, 3, 4
	600	500, 11:11:06, 3, 5
	200	11:11:06
	300	11:11:06
	300

Answer 5

Anonymous

I looked at that link but I am unsure of how to apply that.

0 comments

Share via

Subset Sum in Excel

7 additional answers