Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Combinations with contrstraints
Hi, In column A I have a series of numbers , for example 1 3 10 25 69 70 80 92 ... In cell B1 I have a number, for example 210. How could I get all possible combinations of the numbers present in column A whose sum is equal to 210? Thanks p. |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Combinations with contrstraints
p,
Copy the code below (written by Harlan Grove) into a code module, and set the references as instructed in the comments. Then run findsums and highlight the ranges with your values when prompted. HTH, Bernie MS Excel MVP Option Explicit 'Begin VBA Code Sub findsums() 'This *REQUIRES* VBAProject references to 'Microsoft Scripting Runtime 'Microsoft VBScript Regular Expressions 1.0 or higher 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 ---- wrote in message oups.com... Hi, In column A I have a series of numbers , for example 1 3 10 25 69 70 80 92 ... In cell B1 I have a number, for example 210. How could I get all possible combinations of the numbers present in column A whose sum is equal to 210? Thanks p. |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Combinations with contrstraints
In column A I have a series of numbers , for example 1 3 10 25 69 70
80 92 ... In cell B1 I have a number, for example 210. How could I get all possible combinations of the numbers present in column A whose sum is equal to 210? p. http://www.dicks-blog.com/archives/2...sum-to-target/ -- Dick Kusleika MVP - Excel Daily Dose of Excel http://www.dicks-blog.com |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
combinations | Excel Discussion (Misc queries) | |||
Combinations | Excel Discussion (Misc queries) | |||
Possible Combinations | Excel Discussion (Misc queries) | |||
Combinations | Excel Programming | |||
All combinations | Excel Programming |