Dear Group,
I have a big issue.
Here's the situation:
I have numbers in a column:
123
465
782
134
....
lot of numbers....
And a few sums: 1313, 6464...
I have to find out where those sums are coming from. They should be sums of
the numbers in that column.
To make things harder I do not know how many numbers shall I add together.
Please advise how to write a fuction that helps me out. I know vba but this
looks a bit over my skills.
Many thanks,
Marton
Sub AAA()
Dim rng As Range, cell As Range
Set rng = Columns(1).SpecialCells(xlFormulas, xlNumbers)
For Each cell In rng
MsgBox cell.Address & vbNewLine & _
cell.Formula & vbNewLine & _
cell.DirectPrecedents.Address
Next
End Sub
this probably isn't what you want, but it may give you some ideas.
--
Regards,
Tom Ogilvy
"VilMarci" wrote:
> Dear Group,
>
> I have a big issue.
> Here's the situation:
> I have numbers in a column:
>
> 123
> 465
> 782
> 134
> ....
> lot of numbers....
>
> And a few sums: 1313, 6464...
>
> I have to find out where those sums are coming from. They should be sums of
> the numbers in that column.
> To make things harder I do not know how many numbers shall I add together.
>
> Please advise how to write a fuction that helps me out. I know vba but this
> looks a bit over my skills.
>
> Many thanks,
> Marton
>
>
>
>
if the sums are formulae have you tried the auditing tools (tools...auditing). Select the cell with the formula and then "show precedants"
or have I misunderstood the question?
Hi Marton,
If you mean find the numbers that add up to the sum: you can find many discussions in the Google archives, and lots of warnings
about how this will "eat" your computer.
But the following code from Harlan Grove is said to be the best. Maybe you should try with small sets first.
--
Kind regards,
Niek Otten
'Begin VBA Code
' By Harlan Grove
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 ----
"VilMarci" <[email protected]> wrote in message news:[email protected]...
> Dear Group,
>
> I have a big issue.
> Here's the situation:
> I have numbers in a column:
>
> 123
> 465
> 782
> 134
> ...
> lot of numbers....
>
> And a few sums: 1313, 6464...
>
> I have to find out where those sums are coming from. They should be sums of
> the numbers in that column.
> To make things harder I do not know how many numbers shall I add together.
>
> Please advise how to write a fuction that helps me out. I know vba but this
> looks a bit over my skills.
>
> Many thanks,
> Marton
>
>
>
Hallo Niek,
Thanks for the code.
This is working perfectly
Marton
"Niek Otten" <[email protected]> wrote in message
news:u0H66C%[email protected]...
> Hi Marton,
>
> If you mean find the numbers that add up to the sum: you can find many
> discussions in the Google archives, and lots of warnings about how this
> will "eat" your computer.
> But the following code from Harlan Grove is said to be the best. Maybe you
> should try with small sets first.
>
> --
> Kind regards,
>
> Niek Otten
>
>
> 'Begin VBA Code
>
> ' By Harlan Grove
>
> 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 ----
>
>
>
> "VilMarci" <[email protected]> wrote in message
> news:[email protected]...
>> Dear Group,
>>
>> I have a big issue.
>> Here's the situation:
>> I have numbers in a column:
>>
>> 123
>> 465
>> 782
>> 134
>> ...
>> lot of numbers....
>>
>> And a few sums: 1313, 6464...
>>
>> I have to find out where those sums are coming from. They should be sums
>> of
>> the numbers in that column.
>> To make things harder I do not know how many numbers shall I add
>> together.
>>
>> Please advise how to write a fuction that helps me out. I know vba but
>> this
>> looks a bit over my skills.
>>
>> Many thanks,
>> Marton
>>
>>
>>
>
>
Hello,
Just 1 more thing...
How would possible to include negative numbers?
Marton
"Niek Otten" <[email protected]> wrote in message
news:u0H66C%[email protected]...
> Hi Marton,
>
> If you mean find the numbers that add up to the sum: you can find many
> discussions in the Google archives, and lots of warnings about how this
> will "eat" your computer.
> But the following code from Harlan Grove is said to be the best. Maybe you
> should try with small sets first.
>
> --
> Kind regards,
>
> Niek Otten
>
>
> 'Begin VBA Code
>
> ' By Harlan Grove
>
> 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 ----
>
>
>
> "VilMarci" <[email protected]> wrote in message
> news:[email protected]...
>> Dear Group,
>>
>> I have a big issue.
>> Here's the situation:
>> I have numbers in a column:
>>
>> 123
>> 465
>> 782
>> 134
>> ...
>> lot of numbers....
>>
>> And a few sums: 1313, 6464...
>>
>> I have to find out where those sums are coming from. They should be sums
>> of
>> the numbers in that column.
>> To make things harder I do not know how many numbers shall I add
>> together.
>>
>> Please advise how to write a fuction that helps me out. I know vba but
>> this
>> looks a bit over my skills.
>>
>> Many thanks,
>> Marton
>>
>>
>>
>
>
Hi Marton,,
No idea, really. I thought it worked OK, but a quick test learned me that seems not to be the case.
Sorry I can't help you any further.
You could try Google's newsgroup archives and search for: combinations, sum, harlan, dana
and find out more
--
Kind regards,
Niek Otten
"VilMarci" <[email protected]> wrote in message news:[email protected]...
> Hello,
>
> Just 1 more thing...
> How would possible to include negative numbers?
>
> Marton
>
>
> "Niek Otten" <[email protected]> wrote in message news:u0H66C%[email protected]...
>> Hi Marton,
>>
>> If you mean find the numbers that add up to the sum: you can find many discussions in the Google archives, and lots of warnings
>> about how this will "eat" your computer.
>> But the following code from Harlan Grove is said to be the best. Maybe you should try with small sets first.
>>
>> --
>> Kind regards,
>>
>> Niek Otten
>>
>>
>> 'Begin VBA Code
>>
>> ' By Harlan Grove
>>
>> 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 ----
>>
>>
>>
>> "VilMarci" <[email protected]> wrote in message news:[email protected]...
>>> Dear Group,
>>>
>>> I have a big issue.
>>> Here's the situation:
>>> I have numbers in a column:
>>>
>>> 123
>>> 465
>>> 782
>>> 134
>>> ...
>>> lot of numbers....
>>>
>>> And a few sums: 1313, 6464...
>>>
>>> I have to find out where those sums are coming from. They should be sums of
>>> the numbers in that column.
>>> To make things harder I do not know how many numbers shall I add together.
>>>
>>> Please advise how to write a fuction that helps me out. I know vba but this
>>> looks a bit over my skills.
>>>
>>> Many thanks,
>>> Marton
>>>
>>>
>>>
>>
>>
>
>
Couldn't you adjust the base? Like add lowest number+1 to all numbers and the search argument and subtract again from the results?
--
Kind regards,
Niek Otten
"VilMarci" <[email protected]> wrote in message news:[email protected]...
> Hello,
>
> Just 1 more thing...
> How would possible to include negative numbers?
>
> Marton
>
>
> "Niek Otten" <[email protected]> wrote in message news:u0H66C%[email protected]...
>> Hi Marton,
>>
>> If you mean find the numbers that add up to the sum: you can find many discussions in the Google archives, and lots of warnings
>> about how this will "eat" your computer.
>> But the following code from Harlan Grove is said to be the best. Maybe you should try with small sets first.
>>
>> --
>> Kind regards,
>>
>> Niek Otten
>>
>>
>> 'Begin VBA Code
>>
>> ' By Harlan Grove
>>
>> 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 ----
>>
>>
>>
>> "VilMarci" <[email protected]> wrote in message news:[email protected]...
>>> Dear Group,
>>>
>>> I have a big issue.
>>> Here's the situation:
>>> I have numbers in a column:
>>>
>>> 123
>>> 465
>>> 782
>>> 134
>>> ...
>>> lot of numbers....
>>>
>>> And a few sums: 1313, 6464...
>>>
>>> I have to find out where those sums are coming from. They should be sums of
>>> the numbers in that column.
>>> To make things harder I do not know how many numbers shall I add together.
>>>
>>> Please advise how to write a fuction that helps me out. I know vba but this
>>> looks a bit over my skills.
>>>
>>> Many thanks,
>>> Marton
>>>
>>>
>>>
>>
>>
>
>
No, not like that. But somehow it should be possible to work with a different base (?)
--
Kind regards,
Niek Otten
"Niek Otten" <[email protected]> wrote in message news:[email protected]...
> Couldn't you adjust the base? Like add lowest number+1 to all numbers and the search argument and subtract again from the
> results?
>
> --
> Kind regards,
>
> Niek Otten
>
> "VilMarci" <[email protected]> wrote in message news:[email protected]...
>> Hello,
>>
>> Just 1 more thing...
>> How would possible to include negative numbers?
>>
>> Marton
>>
>>
>> "Niek Otten" <[email protected]> wrote in message news:u0H66C%[email protected]...
>>> Hi Marton,
>>>
>>> If you mean find the numbers that add up to the sum: you can find many discussions in the Google archives, and lots of
>>> warnings about how this will "eat" your computer.
>>> But the following code from Harlan Grove is said to be the best. Maybe you should try with small sets first.
>>>
>>> --
>>> Kind regards,
>>>
>>> Niek Otten
>>>
>>>
>>> 'Begin VBA Code
>>>
>>> ' By Harlan Grove
>>>
>>> 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 ----
>>>
>>>
>>>
>>> "VilMarci" <[email protected]> wrote in message news:[email protected]...
>>>> Dear Group,
>>>>
>>>> I have a big issue.
>>>> Here's the situation:
>>>> I have numbers in a column:
>>>>
>>>> 123
>>>> 465
>>>> 782
>>>> 134
>>>> ...
>>>> lot of numbers....
>>>>
>>>> And a few sums: 1313, 6464...
>>>>
>>>> I have to find out where those sums are coming from. They should be sums of
>>>> the numbers in that column.
>>>> To make things harder I do not know how many numbers shall I add together.
>>>>
>>>> Please advise how to write a fuction that helps me out. I know vba but this
>>>> looks a bit over my skills.
>>>>
>>>> Many thanks,
>>>> Marton
>>>>
>>>>
>>>>
>>>
>>>
>>
>>
>
>
Hi Marton,
If you follow this link there is a routine by Ioannis who claims (somewhere in the supporting discussions) it does negative
numbers as well. I didn't test it.
--
Kind regards,
Niek Otten
"VilMarci" <[email protected]> wrote in message news:[email protected]...
> Hello,
>
> Just 1 more thing...
> How would possible to include negative numbers?
>
> Marton
>
>
> "Niek Otten" <[email protected]> wrote in message news:u0H66C%[email protected]...
>> Hi Marton,
>>
>> If you mean find the numbers that add up to the sum: you can find many discussions in the Google archives, and lots of warnings
>> about how this will "eat" your computer.
>> But the following code from Harlan Grove is said to be the best. Maybe you should try with small sets first.
>>
>> --
>> Kind regards,
>>
>> Niek Otten
>>
>>
>> 'Begin VBA Code
>>
>> ' By Harlan Grove
>>
>> 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 ----
>>
>>
>>
>> "VilMarci" <[email protected]> wrote in message news:[email protected]...
>>> Dear Group,
>>>
>>> I have a big issue.
>>> Here's the situation:
>>> I have numbers in a column:
>>>
>>> 123
>>> 465
>>> 782
>>> 134
>>> ...
>>> lot of numbers....
>>>
>>> And a few sums: 1313, 6464...
>>>
>>> I have to find out where those sums are coming from. They should be sums of
>>> the numbers in that column.
>>> To make things harder I do not know how many numbers shall I add together.
>>>
>>> Please advise how to write a fuction that helps me out. I know vba but this
>>> looks a bit over my skills.
>>>
>>> Many thanks,
>>> Marton
>>>
>>>
>>>
>>
>>
>
>
Sorry:
http://www.mrexcel.com/pc09.shtml
--
Kind regards,
Niek Otten
"Niek Otten" <[email protected]> wrote in message news:[email protected]...
> Hi Marton,
>
> If you follow this link there is a routine by Ioannis who claims (somewhere in the supporting discussions) it does negative
> numbers as well. I didn't test it.
>
>
> --
> Kind regards,
>
> Niek Otten
>
> "VilMarci" <[email protected]> wrote in message news:[email protected]...
>> Hello,
>>
>> Just 1 more thing...
>> How would possible to include negative numbers?
>>
>> Marton
>>
>>
>> "Niek Otten" <[email protected]> wrote in message news:u0H66C%[email protected]...
>>> Hi Marton,
>>>
>>> If you mean find the numbers that add up to the sum: you can find many discussions in the Google archives, and lots of
>>> warnings about how this will "eat" your computer.
>>> But the following code from Harlan Grove is said to be the best. Maybe you should try with small sets first.
>>>
>>> --
>>> Kind regards,
>>>
>>> Niek Otten
>>>
>>>
>>> 'Begin VBA Code
>>>
>>> ' By Harlan Grove
>>>
>>> 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 ----
>>>
>>>
>>>
>>> "VilMarci" <[email protected]> wrote in message news:[email protected]...
>>>> Dear Group,
>>>>
>>>> I have a big issue.
>>>> Here's the situation:
>>>> I have numbers in a column:
>>>>
>>>> 123
>>>> 465
>>>> 782
>>>> 134
>>>> ...
>>>> lot of numbers....
>>>>
>>>> And a few sums: 1313, 6464...
>>>>
>>>> I have to find out where those sums are coming from. They should be sums of
>>>> the numbers in that column.
>>>> To make things harder I do not know how many numbers shall I add together.
>>>>
>>>> Please advise how to write a fuction that helps me out. I know vba but this
>>>> looks a bit over my skills.
>>>>
>>>> Many thanks,
>>>> Marton
>>>>
>>>>
>>>>
>>>
>>>
>>
>>
>
>
There are currently 1 users browsing this thread. (0 members and 1 guests)
Posting Permissions
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks