Combination Sum
 

Hi

I need help in solving for an issue in excel. A macro is required.

We have a list of 700 numbers and we need to find out how many
combinations match a particular number, if we add numbers from the
list of 700. Example:

List of numbers:
1234
63
8903
3446
8112
854
.... and so on

Target: 8966

Solution:
Option 1:
8112+854
Option 2:
63+8903

Is this possible in excel macro. I found one here, but this is not
useful for more than 4 numbers.

http://en.allexperts.com/q/Excel-105...s-x-number.htm

I would appreciate it if a solution to this is available on excel or
any other software.

Combination Sum
 

Hi

This tests for one or two combinations. Put more loops inside the y loop
(like For z = y+1 to 700) for mo

Sub test()
Dim x As Long
Dim y As Long
Dim D1 As Double, D2 As Double
For x = 1 To 699
Application.StatusBar = x
D1 = Cells(x, 1).Value
If D1 = 8966 Then
MsgBox D1, , "Found one"
End If
For y = x + 1 To 700
D2 = Cells(y, 1).Value
If D1 + D2 = 8966 Then
MsgBox D1 & " " & D2, , "Found one"
End If
Next
Next
End Sub

HTH. Best wishes Harald

skrev i melding
...
Hi

I need help in solving for an issue in excel. A macro is required.

We have a list of 700 numbers and we need to find out how many
combinations match a particular number, if we add numbers from the
list of 700. Example:

List of numbers:
1234
63
8903
3446
8112
854
... and so on

Target: 8966

Solution:
Option 1:
8112+854
Option 2:
63+8903

Is this possible in excel macro. I found one here, but this is not
useful for more than 4 numbers.

http://en.allexperts.com/q/Excel-105...s-x-number.htm

I would appreciate it if a solution to this is available on excel or
any other software.

Combination Sum
 

That cannot be done on a PC, and possilby not even on a mainframe, or supercomputer ;-) 700 is
waaaaay too many. Remember factorials? That is what you are looking at, and 700! is a big number -
150! is about 10^264, and I can't even calculate 700!. Anyway, below is the best VBA code for you
to try, perhaps on a _much_ smaller set of numbers.

HTH,
Bernie
MS Excel MVP

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 ----






wrote in message
...
Hi

I need help in solving for an issue in excel. A macro is required.

We have a list of 700 numbers and we need to find out how many
combinations match a particular number, if we add numbers from the
list of 700. Example:

List of numbers:
1234
63
8903
3446
8112
854
... and so on

Target: 8966

Solution:
Option 1:
8112+854
Option 2:
63+8903

Is this possible in excel macro. I found one here, but this is not
useful for more than 4 numbers.

http://en.allexperts.com/q/Excel-105...s-x-number.htm

I would appreciate it if a solution to this is available on excel or
any other software.

Combination Sum
 

There's probably a much more efficient way to do this, but hey - it works!

The code is based on a worksheet being in this exact format.

A B C D E F
1
2 LIST TARGET: NUMBER1 NUMBER2
3 1234 8966
4 63
5 8903
6 3446
7 8112
8 854

Option Explicit
Public Sub FindSolutions()

Dim num1 As Currency
Dim num2 As Currency
Dim aRow As Long
Dim bRow As Long
Const icol As Integer = 1
Dim curTarget As Currency
Const resultCol As Integer = 5
Dim cRow As Long
Dim blnSkip As Boolean

ActiveSheet.Range("E3:F500").ClearContents 'clear existing #s in columns
E-F

curTarget = ActiveSheet.Range("C3") 'target value
aRow = 3 'start at top
Do Until Cells(aRow, icol) = "" 'loop thru list of values in column A
bRow = 3
Do Until Cells(bRow, icol) = "" 'go thru values below cell we're on
right now
num1 = Cells(aRow, icol) 'grab # in current cell
num2 = Cells(bRow, icol) 'grab # in next cell down
If num1 + num2 = curTarget Then 'sum of 2 #s = target value
'CHECK IF THEY'RE ALREADY IN THE LIST OF SOLUTIONS
cRow = 3
blnSkip = False
Do Until Cells(cRow, resultCol) = ""
If Cells(cRow, resultCol) = num2 Then
If Cells(cRow, resultCol + 1) = num1 Then
blnSkip = True '#s are already in solution columns
End If
End If
cRow = cRow + 1
Loop
If blnSkip = False Then 'add these #s to solution lists
Cells(cRow, resultCol) = num1
Cells(cRow, resultCol + 1) = num2
End If
End If
bRow = bRow + 1
Loop
aRow = aRow + 1
Loop

End Sub


Hope this helps!
Mike


" wrote:

Hi

I need help in solving for an issue in excel. A macro is required.

We have a list of 700 numbers and we need to find out how many
combinations match a particular number, if we add numbers from the
list of 700. Example:

List of numbers:
1234
63
8903
3446
8112
854
.... and so on

Target: 8966

Solution:
Option 1:
8112+854
Option 2:
63+8903

Is this possible in excel macro. I found one here, but this is not
useful for more than 4 numbers.

http://en.allexperts.com/q/Excel-105...s-x-number.htm

I would appreciate it if a solution to this is available on excel or
any other software.

Combination Sum
 

Harald,

That works fine if only pairs are added, but how about 3, 4, 5, 6.....699 numbers being added?

Too many.

If it were just pairs, you could use worksheet functions to show the matches:

=IF(NOT(ISERROR(MATCH(8966-A2,$A$2:$A$701,FALSE))),A2 & " & " & 8966-A2,"")

Bernie
MS Excel MVP


"Harald Staff" wrote in message ...
Hi

This tests for one or two combinations. Put more loops inside the y loop (like For z = y+1 to 700)
for mo

Sub test()
Dim x As Long
Dim y As Long
Dim D1 As Double, D2 As Double
For x = 1 To 699
Application.StatusBar = x
D1 = Cells(x, 1).Value
If D1 = 8966 Then
MsgBox D1, , "Found one"
End If
For y = x + 1 To 700
D2 = Cells(y, 1).Value
If D1 + D2 = 8966 Then
MsgBox D1 & " " & D2, , "Found one"
End If
Next
Next
End Sub

HTH. Best wishes Harald

skrev i melding
...
Hi

I need help in solving for an issue in excel. A macro is required.

We have a list of 700 numbers and we need to find out how many
combinations match a particular number, if we add numbers from the
list of 700. Example:

List of numbers:
1234
63
8903
3446
8112
854
... and so on

Target: 8966

Solution:
Option 1:
8112+854
Option 2:
63+8903

Is this possible in excel macro. I found one here, but this is not
useful for more than 4 numbers.

http://en.allexperts.com/q/Excel-105...s-x-number.htm

I would appreciate it if a solution to this is available on excel or
any other software.