# matching 24 different values to a specific value

1. ## matching 24 different values to a specific value

I need to match the sum of a list of 24 different values to a specific value.
How do I write a formula calculating all possible values form the given list?

A combination of the sum of the list should add up to 44,007.31

The data list is as follows:
483.34
758.06
852.67
1,494.61
1,806.25
1,842.28
2,070.88
2,130.14
2,913.33
3,946.90
3,957.38
4,154.26
4,504.18
4,831.08
5,083.52
5,092.55
5,121.39
5,824.48
6,361.67
6,835.00
6,875.09
6,898.54
8,662.80
10,854.69

Your input would be highly appreciated

2. ## Re: matching 24 different values to a specific value

Not quite sure what you are asking. Are you asking like in a bank
statement reconciliation..where you have a known sum which should be a
sum of two or more of the given range of possibilities? This list would
be prohibitive to list (24 options is 25! or 1.5 x10^21 options). There
are some logical ways to come up with the other list (based on no sum
can be greater than the known sum...but it would be a fairly complex
program.

3. ## Re: matching 24 different values to a specific value

Elize,

Using Harlan Grove's code below, there are four solutions found:

=8662.8+6835+5121.39+5083.52+4504.18+3957.38+3946.9+2913.33+2130.14+852.67
=8662.8+6361.67+5824.48+5092.55+4154.26+3957.38+3946.9+2130.14+2070.88+1806.25
=8662.8+6835+5824.48+5083.52+4831.08+3957.38+3946.9+2130.14+1494.61+758.06+483.34
=8662.8+6898.54+5083.52+4154.26+3957.38+3946.9+2913.33+2130.14+2070.88+1842.28+1494.61+852.67

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

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

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

"Elize du Preez" <Elize du Preez@discussions.microsoft.com> wrote in message
news:FD9BBC9E-01CC-4E24-A111-1FCBE06F6787@microsoft.com...
>I need to match the sum of a list of 24 different values to a specific value.
> How do I write a formula calculating all possible values form the given list?
>
> A combination of the sum of the list should add up to 44,007.31
>
> The data list is as follows:
> 483.34
> 758.06
> 852.67
> 1,494.61
> 1,806.25
> 1,842.28
> 2,070.88
> 2,130.14
> 2,913.33
> 3,946.90
> 3,957.38
> 4,154.26
> 4,504.18
> 4,831.08
> 5,083.52
> 5,092.55
> 5,121.39
> 5,824.48
> 6,361.67
> 6,835.00
> 6,875.09
> 6,898.54
> 8,662.80
> 10,854.69
>
>
> Your input would be highly appreciated

4. ## Re: matching 24 different values to a specific value

Bernie

Your assistance was of great help, thanks for your time and effort, it's
much appreciated.

Kind regards

Elize

"Bernie Deitrick" wrote:

> Elize,
>
> Using Harlan Grove's code below, there are four solutions found:
>
> =8662.8+6835+5121.39+5083.52+4504.18+3957.38+3946.9+2913.33+2130.14+852.67
> =8662.8+6361.67+5824.48+5092.55+4154.26+3957.38+3946.9+2130.14+2070.88+1806.25
> =8662.8+6835+5824.48+5083.52+4831.08+3957.38+3946.9+2130.14+1494.61+758.06+483.34
> =8662.8+6898.54+5083.52+4154.26+3957.38+3946.9+2913.33+2130.14+2070.88+1842.28+1494.61+852.67
>
> 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
>
>
> 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
> 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)
> '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

5. ## Re: matching 24 different values to a specific value

Hello soxcpa

Regards

Elize

"soxcpa@gmail.com" wrote:

> Not quite sure what you are asking. Are you asking like in a bank
> statement reconciliation..where you have a known sum which should be a
> sum of two or more of the given range of possibilities? This list would
> be prohibitive to list (24 options is 25! or 1.5 x10^21 options). There
> are some logical ways to come up with the other list (based on no sum
> can be greater than the known sum...but it would be a fairly complex
> program.
>
>

There are currently 1 users browsing this thread. (0 members and 1 guests)

#### Posting Permissions

• You may not post new threads
• You may not post replies
• You may not post attachments
• You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1