mcmuney

11-14-2007, 08:18 PM

:think: I've found the code below, which will find all combinations of cells that add up to a certain number in Excel, but I'm getting the compile error regarding "Dictionary". It doesn't appear to be defined and I'm a newbie and not sure what I need to do to get it to work. See code below and thanks in advance.

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 Dictionary

Dim dcn As Dictionary, dco As Dictionary

Dim re As 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

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 Dictionary

Dim dcn As Dictionary, dco As Dictionary

Dim re As 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