Here is some code. Note that you need to create references to a couple of
librarys in order tom make this code work (In VBE select Tools ->
References).
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0 or higher
This code should be placed in a standard module...
Option Explicit
' Original solution created by
' Harlan Grove
Public Sub FindSums()
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0 or higher
Const TOL As Double = 0.0001 '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
Dim wks As Worksheet
Application.EnableCancelKey = xlErrorHandler
re.Global = True
re.IgnoreCase = True
On Error Resume Next
Set wks = ActiveSheet
Set x = Intersect(Selection, wks.UsedRange)
If x Is Nothing Then
Err.Clear
Exit Sub
End If
y = Application.InputBox( _
Prompt:="Enter target value:", _
Title:="Find Sums", _
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:
If Err = 18 Then
If MsgBox("Do you want to stop searching?", vbYesNo, "Quit?") = vbYes Then
Application.StatusBar = False
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
End
Else
Resume
End If
Else
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
End If
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
If Not SheetExists(OUTPUTWSN, ActiveWorkbook) Then
Application.ScreenUpdating = False
Worksheets.Add Before:=ActiveSheet
Set ws = ActiveSheet
ws.Name = OUTPUTWSN
ws.Cells.NumberFormat = "#,##0.00"
Set r = ws.Range("A2")
Else
Set ws = Sheets(OUTPUTWSN)
ws.Cells.Clear
ws.Cells.NumberFormat = "#,##0.00"
Set r = ws.Range("A2")
End If
recsoln = 0
ElseIf s = "" Then
recsoln = r.Row - 1
Set r = Nothing
Else
Call PostAnswers(s, r)
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
Private Sub PostAnswers(ByVal strValue As String, ByVal rng As Range)
Dim aryCSVValues As Variant
Dim intCounter As Integer
aryCSVValues = Split(Mid$(strValue, 2, Len(strValue)), "+")
For intCounter = LBound(aryCSVValues) To UBound(aryCSVValues)
rng.Value = aryCSVValues(intCounter)
Set rng = rng.Offset(0, 1)
Next intCounter
End Sub
