I wrote this a few years ago. 1. It's very fast and supports negative source
values. It finds all possible combinations up to 10 elements. In a trial just
now with 25 elements and a target value of 87.48, it took two seconds to find
six results. A negative value was included. Time required however is highly
variable. If you use it, please advise on how it goes (pro/con).
1. Paste to a standard module.
2. Select the cells containing the source values.
3. They must all be numeric. Negative values supported.
4. You will be prompted to specify the target value.
5. Max. number of elements in combination (summing to the target value) is
10.
Option Explicit
Dim Abort As Boolean
Sub FindCombins()
Dim cell As Range
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 txt As String
Dim t1 As Date, t2 As Date
Const Title As String = "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
txt = "This macro will find combinations of " & _
"the current cell selection that sum to a specified " & _
"value. If the cells containing the source values " & _
"are not currently selected then press Cancel, select " & _
"thes cells and run the macro again." & vbCr & vbCr & _
"Requirements:" & vbCr & _
"- Source values must be selected before running the " & _
"macro. The selection does not need to be " & _
"contiguous." & vbCr & _
"- Select only cells containing numeric values." & vbCr & _
"- Duplicate values should be removed from the " & _
"selection." & vbCr & _
"- A maximum of 10 elements in combination that sum " & _
"to the target value is supported."
Style = vbInformation + vbOKCancel
Resp = MsgBox(txt, Style, Title)
If Resp = vbCancel Then Exit Sub
col = ActiveCell.Column
txt = vbCr & vbCr & _
"Specify the target value or select cell:"
With Application
v0 = .InputBox(txt, Title)
If v0 = 0 Then Exit Sub
.ScreenUpdating = False
End With
ReDim Ar(0 To Application.Max(Selection.Count, 9))
Ar(0) = 0
I = 0
For Each cell In Selection.Cells
I = I + 1
Ar(I) = cell.Value
Next
If I < 9 Then
x = 0
For j = I + 1 To 9
x = x + 1
Ar(j) = v0 + x
Next
End If
Ar = SortArray(Ar)
Call FindDupes(Ar)
If Abort Then Exit Sub
DoEvents
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
SkipToHere:
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
Set cell = Nothing
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 produce duplicate " & _
"results and thus slow performance and serve no purpose. You are " & _
"advised to remove the duplicate values and run the macro again." & _
vbCr & vbCr & "Continue ?"
Resp = MsgBox(txt, vbOKCancel + vbExclamation, "Find Combinations")
If Resp = vbCancel Then Abort = True
End Sub
