I have to reconcile a group of numbers against one number and about 1/3
of the numbers are negative. This code is excellent but ignores
negative numbers and also returns (for some reason) a "Subscript Out of
Range" error message when doing some blocks of numbers. As an example
I had about 20 numbers which I needed to reconcile against one
(probably 2-4 made up the one) and I got this error.

Any Ideas?

Here is the code I used:






Option Explicit
'Begin VBA Code


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

I can't help you with Harlan's code. I wrote this a long time ago and it
appears to work with negatives. I believe it will suffice. It is limited to a
maximum of 10 elements in combination and a minimum of 9 values can be
selected. Text cannot be in the selection. If interested, copy and paste to a
standard code module and correct word wrap (text will turn red).

Tested only briefly with negatives just now. It was (if I have the correct
version) rigorously tested with positive values when written a few years ago,
then mothballed.

You will prompted for the target value. The macro will insert a new column
in the active sheet and will list all combinations found to meet the target
value in this form:

-10.44 + 0.45 + 1.54 + 11.11 + 12.22 + 14.94
-5.19 + 0.45 + 1.54 + 5 + 5.45 + 7.63 + 14.94
0.45 + 0.99 + 1.18 + 4.53 + 5 + 5.45 + 12.22

For testing purposes, if you put an equals sign (=) in front of each of the
above Excel will convert them to formulas. The cells will, in this case,
return the value 29.82.

Regards,
Greg


Option Explicit
Dim Abort As Boolean

Sub FindCombins()
Dim a As Long, b As Long, c As Long
Dim d As Long, e As Long, f As Long
Dim g As Long, h As Long, i As Long
Dim j As Long, x As Long, y As Long
Dim s1 As Long, s2 As Long, s3 As Long
Dim s4 As Long, s5 As Long, s6 As Long
Dim s7 As Long, s8 As Long, s9 As Long
Dim s10 As Long, col As Long
Dim Resp As Integer, Style As Integer
Dim v As Single, v0 As Single, Ar() As Double
Dim cell As Range
Dim txt As String, Title As String
Dim t1 As Date, t2 As Date

Title = "Find Combinations"
s1 = 0: s2 = 0: s3 = 0: s4 = 0: s5 = 0
s6 = 0: s7 = 0: s8 = 0: s9 = 0: s10 = 0
On Error GoTo SkipToHere
If Selection.Count < 9 Then
txt = "Error: A minimum of nine values must be selected !!! "
MsgBox txt, vbCritical, Title
Exit Sub
End If
txt = "This macro will find combinations of the current " & _
"cell selection that equal a specified value. " & vbCr & vbCr & _
"- A maximum of 10 elements in combination is supported" & vbCr & _
"- A minimum of 9 values must be selected" & vbCr & _
"- The selection need not be contiguous" & vbCr & _
"- Only numeric values must be selected" & vbCr & _
"- Duplicate values should be removed from the selection"
Style = vbInformation + vbOKCancel
Resp = MsgBox(txt, Style, Title)
If Resp = vbCancel Then Exit Sub

col = ActiveCell.Column
ReDim Ar(0 To Selection.Count)
Ar(0) = 0
i = 1
For Each cell In Selection.Cells
Ar(i) = cell.Value
i = i + 1
Next
Ar = SortArray(Ar)

Call FindDupes(Ar)
If Abort Then Exit Sub

txt = vbCr & vbCr & "Specify target value:"
With Application
v0 = .InputBox(txt, Title)
If v0 = 0 Then Exit Sub
.ScreenUpdating = False
End With
t1 = Now
ActiveCell.EntireColumn.Insert
x = 0
y = UBound(Ar)
'xxxxxxxxxxxx Start Loop xxxxxxxxxx
For a = s1 To y - 9: For b = a + s2 To y - 8
For c = b + s3 To y - 7: For d = c + s4 To y - 6
For e = d + s5 To y - 5: For f = e + s6 To y - 4
For g = f + s7 To y - 3: For h = g + s8 To y - 2
For i = h + s9 To y - 1: For j = i + s10 To y

v = Ar(a) + Ar(b) + Ar(c) + Ar(d) + Ar(e) + Ar(f) + Ar(g) + Ar(h) + Ar(i) +
Ar(j)
If v = v0 Then
x = x + 1
txt = GetText(Ar(a), Ar(b), Ar(c), Ar(d), Ar(e), Ar(f), Ar(g), Ar(h),
Ar(i), Ar(j))
Cells(x, col) = txt
txt = ""
ElseIf v v0 Then
Exit For
End If

s10 = 1: Next: s9 = 1: Next: s8 = 1: Next: s7 = 1: Next: s6 = 1: Next
s5 = 1: Next: s4 = 1: Next: s3 = 1: Next: s2 = 1: Next: s1 = 1: Next
'xxxxxxxxxxxx End Loop xxxxxxxxxxxxxx
SkipToHe
Columns(col).EntireColumn.AutoFit
t2 = Now
If x 65536 Then
txt = "Too many combinations found. Max capacity 65536. "
Style = vbExclamation
ElseIf x = 0 Then
'Columns(col).Delete
If Err.Number = 0 Then
txt = "No combinations were found equalling " & v0 & " "
Else
txt = "An error caused the macro to fail. " & vbCr & vbCr & _
"- Ensure that the selection does not include text" & vbCr & _
"- Ensure that a minimum of seven values are selected" & vbCr & _
"- Ensure that numeric values are not formated with apostrophes"
End If
Style = vbExclamation
Else
txt = "Combinations found equalling " & v0 & " = " & x & " " & _
vbCr & vbCr & _
"Hours = " & Hour(t2 - t1) & vbCr & _
"Minutes = " & Minute(t2 - t1) & vbCr & _
"Seconds = " & Second(t2 - t1)
Style = vbOKOnly
End If
ActiveCell.Select
Application.ScreenUpdating = True
MsgBox txt, Style, Title
End Sub
Private Function GetText(a As Double, b As Double, c As Double, d As Double, _
e As Double, f As Double, g As Double, h As Double, i As Double, j As
Double) As String
Dim Ar As Variant
Dim x As Integer
Dim t As String
Ar = Array(a, b, c, d, e, f, g, h, i, j)
For x = 9 To 0 Step -1
If Ar(x) = 0 Then Exit For
t = " + " & Ar(x) & t
Next
GetText = Right(t, Len(t) - 3)
End Function

Private Function SortArray(Ar As Variant) As Variant
Dim i As Integer, j As Integer
Dim Temp As Double
For i = LBound(Ar) To UBound(Ar) - 1
For j = (i + 1) To UBound(Ar)
If Ar(i) Ar(j) And Ar(i) < 0 Then
Temp = Ar(j)
Ar(j) = Ar(i)
Ar(i) = Temp
End If
Next j
Next i
SortArray = Ar
End Function
Private Sub FindDupes(Ar As Variant)
Dim i As Integer, ii As Integer, cnt As Integer
Dim val As Double
Dim ar2() As Variant
Dim ar3() As Variant
Dim txt As String, txt2 As String
Dim Style As Integer
Dim Resp As Integer
Dim Dupes As Boolean

Dupes = False
Abort = False
ii = 0
For i = LBound(Ar) + 1 To UBound(Ar)
If Ar(i) = Ar(i - 1) Then
Dupes = True
cnt = 0
val = Ar(i)
ReDim Preserve ar2(ii)
ReDim Preserve ar3(ii)
ar2(ii) = Ar(i)
Do Until Ar(i) < Ar(i - 1)
i = i + 1
cnt = cnt + 1
If i = UBound(Ar) Then Exit Do
Loop
ar3(ii) = cnt + 1
ii = ii + 1
End If
Next
If Not Dupes Then Exit Sub
For i = LBound(ar2) To UBound(ar2)
txt2 = txt2 & "Value: " & ar2(i) & " Repetitions: " & ar3(i) & vbCr
Next
txt = "Duplicate values found in selection:" & vbCr & txt2 & _
vbCr & vbCr & "The presence of duplicates will slow performance and serves
no purpose. " & _
vbCr & vbCr & "Continue ?"

Resp = MsgBox(txt, vbOKCancel + vbExclamation, "Find Combinations")
If Resp = vbCancel Then Abort = True
End Sub