Hi,

Each cell in Range("A1:A100") contains an integer. I would like a macro
or function that will generate a list of all possible numbers in the
range that SUM up to 70 and place them in column C. The delimiter I'd
like to use for each solution is "\".

For example, column C could contain:
C1: 20 \ 50
C2: 60 \ 10
C3: 15 \ 35 \ 20
c4: 17 \ 33 \ 16 \4

.. and so on..

Any help would be appreciated.

Thanks
Jay



*** Sent via Developersdex http://www.developersdex.com ***

It depends how many of the 100 integers you're allowed to use in the sum, ie
if you set the limit at 5 you would rule out 1+2+3+4+5+55 because it
contained 6 components.

If you don't limit yourself to a low number it'll take far far too long to
try all combinations.

The code below works for at most 3 combinations - you can extend this to
more using the obvious pattern. It goes to 101 rows on purpose otherwise
you're accidentally specifying exactly 3 components, not up to 3.

Sub demo()

Dim a As Integer
Dim b As Integer
Dim c As Integer

Dim z As Integer

With Range("a1")

For a = 0 To 101
For b = a + 1 To 101
For c = b + 1 To 101
If .Offset(a, 0).Value + .Offset(b, 0).Value + .Offset(c,
0).Value = 70 Then
.Offset(z, 1).Value = .Offset(a, 0).Value & " / " &
..Offset(b, 0).Value & " / " & .Offset(c, 0).Value
z = z + 1
End If
Next c
Next b
Next a

End With

End Sub

"jay dean" wrote:

Hi,

Each cell in Range("A1:A100") contains an integer. I would like a macro
or function that will generate a list of all possible numbers in the
range that SUM up to 70 and place them in column C. The delimiter I'd
like to use for each solution is "\".

For example, column C could contain:
C1: 20 \ 50
C2: 60 \ 10
C3: 15 \ 35 \ 20
c4: 17 \ 33 \ 16 \4

.. and so on..

Any help would be appreciated.

Thanks
Jay



*** Sent via Developersdex http://www.developersdex.com ***

That should be

..Offset(z, 2).Value ...

not

..Offset(z, 1).Value ...

"Sam Wilson" wrote:

It depends how many of the 100 integers you're allowed to use in the sum, ie
if you set the limit at 5 you would rule out 1+2+3+4+5+55 because it
contained 6 components.

If you don't limit yourself to a low number it'll take far far too long to
try all combinations.

The code below works for at most 3 combinations - you can extend this to
more using the obvious pattern. It goes to 101 rows on purpose otherwise
you're accidentally specifying exactly 3 components, not up to 3.

Sub demo()

Dim a As Integer
Dim b As Integer
Dim c As Integer

Dim z As Integer

With Range("a1")

For a = 0 To 101
For b = a + 1 To 101
For c = b + 1 To 101
If .Offset(a, 0).Value + .Offset(b, 0).Value + .Offset(c,
0).Value = 70 Then
.Offset(z, 1).Value = .Offset(a, 0).Value & " / " &
.Offset(b, 0).Value & " / " & .Offset(c, 0).Value
z = z + 1
End If
Next c
Next b
Next a

End With

End Sub

"jay dean" wrote:

Hi,

Each cell in Range("A1:A100") contains an integer. I would like a macro
or function that will generate a list of all possible numbers in the
range that SUM up to 70 and place them in column C. The delimiter I'd
like to use for each solution is "\".

For example, column C could contain:
C1: 20 \ 50
C2: 60 \ 10
C3: 15 \ 35 \ 20
c4: 17 \ 33 \ 16 \4

.. and so on..

Any help would be appreciated.

Thanks
Jay



*** Sent via Developersdex http://www.developersdex.com ***

Do you have duplicates in your range?
--
Earl Takasaki


"jay dean" wrote:

Hi,

Each cell in Range("A1:A100") contains an integer. I would like a macro
or function that will generate a list of all possible numbers in the
range that SUM up to 70 and place them in column C. The delimiter I'd
like to use for each solution is "\".

For example, column C could contain:
C1: 20 \ 50
C2: 60 \ 10
C3: 15 \ 35 \ 20
c4: 17 \ 33 \ 16 \4

.. and so on..

Any help would be appreciated.

Thanks
Jay



*** Sent via Developersdex http://www.developersdex.com ***

Hi friends,

I need a macro or formulas that replicate a line of equal numbers of cells
to another line after
Thanks

Rui

"jay dean" escreveu:

Hi,

Each cell in Range("A1:A100") contains an integer. I would like a macro
or function that will generate a list of all possible numbers in the
range that SUM up to 70 and place them in column C. The delimiter I'd
like to use for each solution is "\".

For example, column C could contain:
C1: 20 \ 50
C2: 60 \ 10
C3: 15 \ 35 \ 20
c4: 17 \ 33 \ 16 \4

.. and so on..

Any help would be appreciated.

Thanks
Jay



*** Sent via Developersdex http://www.developersdex.com ***

Earl, No, I don't have duplicates in my range.

Thanks,
Jay

*** Sent via Developersdex http://www.developersdex.com ***

an excellent solution Written by Harlan Grove
but 100 are too many cells

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

regards
r

--
Come e dove incollare il codice:
http://www.rondebruin.nl/code.htm

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/...ternative.html


"jay dean" wrote:

Hi,

Each cell in Range("A1:A100") contains an integer. I would like a macro
or function that will generate a list of all possible numbers in the
range that SUM up to 70 and place them in column C. The delimiter I'd
like to use for each solution is "\".

For example, column C could contain:
C1: 20 \ 50
C2: 60 \ 10
C3: 15 \ 35 \ 20
c4: 17 \ 33 \ 16 \4

.. and so on..

Any help would be appreciated.

Thanks
Jay



*** Sent via Developersdex http://www.developersdex.com ***

This doesn't place the results in ColumnC, but you may find a use for it:

Sub FindSeries()

Dim StartRng As Range
Dim EndRng As Range
Dim Answer As Long
Dim TestTotal As Long

Answer = Range("B1") '<<< CHANGE

Set StartRng = Range("A1")
Set EndRng = StartRng
Do Until False
TestTotal = Application.Sum(Range(StartRng, EndRng))
If TestTotal = Answer Then
Range(StartRng, EndRng).Select
Exit Do
ElseIf TestTotal Answer Then
Set StartRng = StartRng(2, 1)
Set EndRng = StartRng
Else
Set EndRng = EndRng(2, 1)
If EndRng.Value = vbNullString Then
MsgBox "No series found"
Exit Do
End If
End If
Loop
End Sub

HTH,
Ryan---

--
Ryan---
If this information was helpful, please indicate this by clicking ''Yes''.


"r" wrote:

an excellent solution Written by Harlan Grove
but 100 are too many cells

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

regards
r

--
Come e dove incollare il codice:
http://www.rondebruin.nl/code.htm

Earl, No, I don't have duplicates in my range.

... Each cell in Range("A1:A100") contains an integer.
... that SUM up to 70

If we assume you mean positive integers in A1:A100, I would start by
eliminating those numbers that are over 70.

Do you have consecutive integers 1,2,3...70 ?
= = =
Dana DeLouis

jay dean wrote:
Earl, No, I don't have duplicates in my range.

Thanks,
Jay

*** Sent via Developersdex http://www.developersdex.com ***

Dana,

No, they are all positive integers. None contains a zero.
And, the numbers are not consecutive.

Thanks
Jay


*** Sent via Developersdex http://www.developersdex.com ***