Can this be done in Excel?

T

twalls2

How can I make Excel or maybe some other program search through 1
different numeric values say A1 thru A14 and list out the combinatio
of cells that add up to exactly equal to a number that I enter into
particular cell?

For example if the numbers were 1-14 in the 14 cells and I enter a 2
in a selected input cell, I want the program to list out the cells tha
add up to 25 like A1,A10,A14 or list the actual values that equal 2
like 1,10,14 in a selected output cell.

Can this be done in Excel? If so please explain how? If not do you kno
of a program that I could purchase that will allow me do this.

Thanks
 
G

Guest

Hi
I suppose that your data are in column A and the particular cell is C
On the cell B1
=if(A1=C$1,"IDEM",""
then do an autofill (click on the right back of the cell and the formula will go on the all column
Then you will just have to look at your column (think to do a sort in data if you have to many data
If you absolutly want a litle box wicht will tell you wicth are the stocks with the same number, you can do that with a macro

Public Sub littlemessage(

Dim rangecell As Rang

For Each cell In Range("A1:" & Range("A1").End(xlDown).Address
If cell.Value = Range("C1").Value The
If rangecell Is Nothing The
Set rangecell = cel
Els
Set rangecell = Union(rangecell, cell
End I
End I
Next cel

if rangecell is not nothing then
MsgBox ("The cell wicht have the same number than the particular one are:" & rangecell.Address
end i
End Su
 
T

twalls2

Thanks for the response but unfortunately it didn't work.

If anybody knows how to accomplish this I would greatly appreciate any
help I can get.

Thanks a Bunch!
 
D

Doug Glancy

I've been looking at this for a while now. I think the short answer is that
it's impracticable because of the number of permutations. The way I figure
it (not a mathematician) the number of permutations is the 2 to the power of
the high number, e.g., 14 in your request is 16,384 combinations of possible
number to look at.

Anyways, I went ahead and wrote something that prints the combos to the
second spreadsheet in the workbook. It asks you for the high number, e.g.,
14 and the number you are looking for. If you enter a high number more than
16, it won't print the sheet because 2 to the power of 16 is 65,536, the
number of rows in a sheet. I entered 16 and got tired of waiting for it to
calculate. So my advice is start with small numbers and work your way up
and save your work before hand.

Anyways, it show all the possible combinations and highlights the ones
you're looking for on the spreadsheet.

The other part of the macro is that it writes the combos that add up to your
target number to the immediate window.

Let me know what you think:


Sub combo_nums()

Dim high_num, find_num, combo_num, combos(), i, j, k, _
group_start, group_end, increment, result As Double

Worksheets(1).Cells.Clear
Application.ScreenUpdating = False

high_num = CDbl(InputBox("Highest Number"))
find_num = CDbl(InputBox("Number to Find"))

combo_num = (2 ^ high_num) - 1
ReDim combos(1 To high_num, 1 To combo_num)

For i = 1 To high_num
increment = (combo_num + 1) / (2 ^ i)
For j = 1 To 2 ^ (i - 1)
group_start = 1 + (increment * 2) * (j - 1)
group_end = group_start + increment - 1
For k = group_start To group_end
combos(i, k) = i
Next k
Next j
Next i

If high_num <= 16 Then
For i = 1 To high_num
For j = 1 To combo_num
Worksheets(1).Cells(j, i) = combos(i, j)
Next j
Next i
Worksheets(1).Range(Worksheets(1).Cells(1, high_num + 2), _
Worksheets(1).Cells(combo_num, high_num + 2)) _
.FormulaR1C1 = "=SUM(RC[-" & high_num + 1 & "]:RC[-2])"
For i = combo_num To 1 Step -1
If Worksheets(1).Cells(i, high_num + 2).Value = find_num Then
Worksheets(1).Rows(i).EntireRow.Font.Bold = True
End If
Next i
Worksheets(1).UsedRange.Columns.AutoFit
Else
MsgBox "Not enough rows in spreadsheet" & vbCrLf & " to list all the
permutations"
End If

Application.ScreenUpdating = True

For j = 1 To combo_num
result = 0
For i = 1 To high_num
result = result + combos(i, j)
Next i
If result = find_num Then
For k = 1 To high_num
Debug.Print combos(k, j);
Next k
Debug.Print vbCrLf
End If
Next j

End Sub
 
T

twalls2

Doug Glancy your awesome buddy!

We're getting somewhere now. I was able to make it work with small
numbers 1 or 2 digits but I do actually have up to 4 digit numbers. It
would run out of memory when trying 4 digit numbers.

But there may be something that could be done to simplify it because it
is getting every possible combination but I only need one combination
that equals to my number. Any one combination is enough.

So is there a way to tell it to stop after it finds the first
combination that equals my number? That would cut the run time down and
memory usage down also if it could stop at that point.

Also I'm using 14 different values to calculate with and here are the
actual number values that I have to use:
8000
4000
2099
1000
800
400
101
100
40
10
8
4
2
1

I have these to use for possible numbers to add together to make #1001
thru #9999 but I only need one combination for each number possible to
create with these given values. There are a lot of numbers between 1001
and 9999 that can't be made with these values but that's okay I just
need all that can be done.

Doug I appreciate the time you spent on this and for someone you don't
even know that's very nice of you. I never dreamed this would be so
complicated and if you can't spend any more time on it that's okay, but
it does look like you're pretty close to whipping this thing.

Thanks Again!
 
T

twalls2

Just one more thing I wanted to add. If 14 numbers are a little too much
for it then maybe it would help make it possible to do if we drop it
down to only 13 or 12 numbers. If that would help then you could drop
the 8000 and maybe the 4000 and if we could make it work with the
remaining 12 numbers from 2099 down to 1 then I could still figure
combinations up to 4565 which would be great also.
 
T

twalls2

Doug time isn't much of an issue at all. No rush at all.

Thanks again for all your help!

Troy
 
G

Greg Wilson

I responded to your post yesterday through DevDex but it
has yet to materialize. This is at the risk of double
posting.

The trick is to first sort the values in the source range
in ascending order. Then test the combinations against
the target value using nested loops. The loops must be
designed to abort once the combination exceeds the target
value because, due to the ascending order, the
combinations can only increase. Note that this approach
is extremely fast. Also note that we are only conscerned
with combinations as apposed to permuations. For example,
12 + 44 and 44 + 12 are different permuations but are the
same combination.

I developed an extensive macro that does this a while back
which you are welcome to. It was developed for a much
more challenging situation than your example. The time
required to return the results for your example should be
essentially instantaneous.

Be advised that the number of results is extremely
sensitive to 1) the number of elements in the source list,
2) the size of the target value and 3) the maximum number
of elements allowed to sum to the target value. It is
amazingly simple to get a situation where there are many
thousands of results. I developed a filter for the macro
that lets you easily control the above parameters as well
as the maximum numbers of results returned.

Post if you're interested.

Regards,
Greg
 
D

Doug Glancy

Greg,

I'd like to see it. One clarification, mine did combinations - I used the
wrong phrase. Still it is slow and I was kinda waiting for the better
answers. It would be very instructive to see yours.

Doug
 
G

Greg Wilson

There are actually 3 macros functioning as one totalling
371 lines. This might be considered excessive for posting
to a news group (???). In that the OP has indicated that
he was willing to pay for such a utility if available in
my opinion proves that his need is serious and therefore
deserves this consideration. You have indicated interest
as well. Before posting, I would like your opinion and/or
other opinions as to whether this is excessive.

A large part of the code involves creating on the fly a UF
that allows you to input the target value as well as to
select filter criteria. Therefore, it's not as big and
ugly as it sounds.

Regards,
Greg
 
T

Tom Ogilvy

Put your numbers in Column B, starting in B1
Put the number to sum to in A1
Run TestBldBin

this will list all combinations in columns going to the right - obviously it
runs out of room at 256. If nothing is shown, there are no combinations
(for example 9999 with the sample 14 numbers).

Sub bldbin(num As Long, bits As Long, arr() As Long)
Dim lNum As Long, i As Long
lNum = num
' Dim sStr As String
' sStr = ""
cnt = 0
For i = bits - 1 To 0 Step -1
If lNum And 2 ^ i Then
cnt = cnt + 1
arr(i, 0) = 1
' sStr = sStr & "1"
Else
arr(i, 0) = 0
' sStr = sStr & "0"
End If
Next
' If cnt = 2 Then
' Debug.Print num, sStr
' End If
End Sub

Sub TestBldbin()
Dim i As Long
Dim bits As Long
Dim varr As Variant
Dim varr1() As Long
Dim rng As Range
Dim icol As Long
icol = 0
Set rng = Range(Range("B1"), Range("B1").End(xlDown))
num = 2 ^ rng.Count - 1
bits = rng.Count
varr = rng.Value
ReDim varr1(0 To bits - 1, 0 To 0)
For i = 0 To num
bldbin i, bits, varr1
tot = Application.SumProduct(varr, varr1)
If tot = Range("A1") Then
icol = icol + 1
rng.Offset(0, icol) = varr1
If icol = 256 Then
MsgBox "too many columns, i is " & i & " of " & num & _
" combinations checked"
Exit Sub
End If
End If
Next
End Sub
 
D

Doug Glancy

Greg,

I don't know if it breaches any etiquette. 400 lines is a very small
percentage of what passes through this group on a daily basis, so I'd guess
it's okay. It's just a curiosity on my part, although it took me more time
than I'd care to admit to write what I did, so, like I said, it would be
educational.

I appreciate your willingness to share it but understand if you decide
otherwise.

Doug
 
I

ian123

Greg, if the offer to see your macro is still available i'd be very
interested in seeing it if i may. (Would you need an email address for
this? Let me know if thats the case)

In the meantime, can anyone help with this related query?

I have been trying to create a macro that will do something very
similar but with 6,7 or 8 digit numbers. The number i want to match to
is also 6-8 digits. The actual numbers of solutions willbe quite small
(usually less than 10) but due to the limits on excel i can't use the
above method. Does anyone have any ideas how i can get around this
problem?

If this sounds to vague to anyone here's a short but more detailed
example of what i mean below:


Basically i need to know which of the 8 values (the no.of values will
range from 5-50+!!!) in column A make up the values in Column B.
(Please note: the numbers are simply examples, they will never be the
same on 2 different occasions!)

Column A: Column B:
540,250 2,546,800 (the sum of the 1st, 3rd, 5th no.)
8,300,120 9,109,120 (the sum of the 2nd and 8th)
7,500 50 (the 6th no.)
123,500 598,500 (the sum of the 4th and 7th)
1,999,050
50
475,000
809,000


I have both the sets of numbers - its just very tricky to link them
manually sometimes! If anyone can help me solve this i'll be extremely
grateful.
 
G

Greg Wilson

Doug,

The complete code follows. Unfortunately, I can't post
through DevDex which gives me more horizontal space. The
code will be severely effected by word wrap errors. You'll
have to fix it. I had to remove all indentation to limit
word wrap.

Note:- You must first select the cells containing the
source values before running the macro. The on-the-fly UF
will allow you to input the target value and select filter
criteria. An oversight on my part is that the code does
not advise the user to first select the source data. You
might consider fixing this. It was originally designed
for decimal values such as currency. Try it under a
situation more challenging than just integers.

I use John Walkenbauch's BubbleSort procedure to sort the
array made of the selected numbers. The sorting is done
in memory - the original data is left alone. Please
maintain the credit to John in the code. Please advise of
the outcome.

Hope it goes well.

Regards,
Greg


Option Explicit
Option Base 1
Public Target As Double
Public Tol As Single
Public MaxElem As Integer
Public MaxResults As Integer

Dim List() As Variant, CumList() As Variant, DynList As
Variant
Dim SumVal As Double
Dim num As Integer, RefCell As Range
Dim a As Integer, b As Integer, C As Integer, d As Integer
Dim e As Integer, f As Integer, g As Integer, h As Integer
Dim i As Integer, j As Integer

Sub GW_FindCombinations()
Dim Prompt As String, Title As String, Style As Integer
Dim Resp As Integer, i As Integer, Cell As Range

Call MakeUF 'Create and call user form to get Target value
and filter criteria.

If Target = 0 Then Exit Sub

SumVal = 0
a = 0: b = 0: C = 0: d = 0: e = 0: f = 0: g = 0: h = 0: i
= 0: j = 0

'***** Establish number of elements in list and dimention
arrays *****
num = Selection.Cells.Count + 1 'Additional element in
list to be assigned value of zero.
ReDim List(num)
ReDim CumList(num)

'***** Exit if non-numeric value found in list else assign
selected cell values to list *****
i = 1 'Assign i an initial value of 1 so first value
assigned to array is element 2.
List(1) = 0
CumList(1) = 0
For Each Cell In Selection.Cells
If Not IsNumeric(Cell) Then
MsgBox "Error: Non-numeric value found in the selected
list. " & _
"Only numeric values allowed in list. ",
vbCritical, "Combinations Analysis"
Exit Sub
Else
i = i + 1
List(i) = Cell 'Populate List array with selected elements
leaving first element (item 0) equal to zero.
End If
Next

'***** Sort list in ascending order *****
Call BubbleSort(List())
'***** Establish CumList values as cumulative values of
selected cells *****
For i = 2 To num
CumList(i) = CumList(i - 1) + List(i)
Next

If Target = 0 Then Exit Sub
'***** Calculate maximum number of elements summed
required to exceed Target value *****
For i = 1 To num
If CumList(i) > Target + Tol Then Exit For
Next
'***** Prompt for option to specify max. number of
elements required to sum to Target value *****

If i - 2 > 10 Then
Prompt = "The macro has a limit of 10 elements that can
sum to the target value. It has been determined " & _
"that more than 10 elements from the currently selected
list can sum to " & Target & ". Therefore, you must " & _
"reduce the number of elements in the list, specify a
lower target value or accept an incomplete list of " & _
"results." & vbCr & vbCr & _
"Continue ???"
Style = vbQuestion + vbYesNo
Title = "GW_FindCombinations"
Resp = MsgBox(Prompt, Style, Title)
If Resp = vbNo Then Exit Sub
End If

If MaxElem = 0 Then
Exit Sub
Else
'Format column to right of selection to receive results.
Set RefCell = ActiveCell.Offset(, Selection.Columns.Count)
RefCell.EntireColumn.Insert
Set RefCell = RefCell.Offset(, -1)
With RefCell
..EntireColumn.HorizontalAlignment = 2
..EntireColumn.IndentLevel = 1
..Font.Bold = True
..Value = "Results for Target = " & Target
..Columns.AutoFit
End With
End If
Call MainProc

End Sub
Private Sub MainProc()
Dim z As Integer, NumElem As Integer, NumResults As Integer
Dim Nb As Integer, Nc As Integer, Nd As Integer, Ne As
Integer
Dim Nf As Integer, Ng As Integer, Nh As Integer, Ni As
Integer
Dim Nj As Integer, StartTime As Date, EndTime As Date,
Duration As Variant
Dim Prompt1 As String, Prompt2 As String
Dim Title As String, Style As Integer, Txt As String

StartTime = Now
On Error Resume Next
Application.ScreenUpdating = False

Nb = 0: Nc = 0: Nd = 0: Ne = 0: Nf = 0: Ng = 0: Nh = 0: Ni
= 0: Nj = 0
NumElem = 1

For a = 1 To num: Call CalcSumVal
If SumVal > Target + Tol Then Exit For
For b = a + Nb To num: Call CalcSumVal
If SumVal > Target + Tol Then
b = a + 2: C = a + 3: d = a + 4: e = a + 5: f = a + 6: g =
a + 7: h = a + 8: i = a + 9: j = a + 10
Exit For
End If
For C = b + Nc To num: Call CalcSumVal
If SumVal > Target + Tol Then
C = b + 2: d = b + 3: e = b + 4: f = b + 5: g = b + 6: h =
b + 7: i = b + 8: j = b + 9
Exit For
End If
For d = C + Nd To num: Call CalcSumVal
If SumVal > Target + Tol Then
d = C + 2: e = C + 3: f = C + 4: g = C + 5: h = C + 6: i =
C + 7: j = C + 8
Exit For
End If
For e = d + Ne To num: Call CalcSumVal
If SumVal > Target + Tol Then
e = d + 2: f = d + 3: g = d + 4: h = d + 5: i = d + 6: j =
d + 7
Exit For
End If
For f = e + Nf To num: Call CalcSumVal
If SumVal > Target + Tol Then
f = e + 2: g = e + 3: h = e + 4: i = e + 5: j = e + 6
Exit For
End If
For g = f + Ng To num: Call CalcSumVal
If SumVal > Target + Tol Then
g = f + 2: h = f + 3: i = f + 4: j = f + 5
Exit For
End If
For h = g + Nh To num: Call CalcSumVal
If SumVal > Target + Tol Then
h = g + 2: i = g + 3: j = g + 4
Exit For
End If
For i = h + Ni To num: Call CalcSumVal
If SumVal > Target + Tol Then
i = h + 2: j = h + 3
Exit For
End If
For j = i + Nj To num: Call CalcSumVal
If SumVal > Target + Tol Then
j = i + 2
Exit For
End If

If NumElem > MaxElem Then GoTo EndMsg

If Abs(SumVal - Target) <= Tol Then

For z = 1 To 9
If DynList(z) > 0 Then
Txt = Txt & DynList(z) & " + "
End If
Next
Txt = Txt & DynList(10) & " = " & SumVal

Set RefCell = RefCell.Offset(1)
RefCell.Value = Txt
Txt = ""
NumResults = NumResults + 1
If NumResults = MaxResults Then
MsgBox "Limit of " & MaxResults & " results reached.
Macro aborted. ", _
vbExclamation, "Combinations Analysis"
GoTo EndMsg
End If

End If

Next j: Nj = 1: NumElem = 2
Next i: Ni = 1: NumElem = 3
Next h: Nh = 1: NumElem = 4
Next g: Ng = 1: NumElem = 5
Next f: Nf = 1: NumElem = 6
Next e: Ne = 1: NumElem = 7
Next d: Nd = 1: NumElem = 8
Next C: Nc = 1: NumElem = 9
Next b: Nb = 1: NumElem = 10
Next a

EndMsg:

RefCell.EntireColumn.AutoFit

EndTime = Now
Duration = Format(EndTime - StartTime, "hh:mm:ss")
If NumResults = 0 Then
Prompt1 = "Sorry, no combinations were found that sum to "
& Target & ". " & vbCr & vbCr
Prompt2 = "Duration = " & Duration
Else
Prompt1 = "Analysis complete !!!" & vbCr & vbCr
Prompt2 = "Duration = " & Duration & vbCr & _
"Number of combinations found that sum to " & Target & "
= " & NumResults & " "
End If

Application.ScreenUpdating = True
Style = vbInformation
Title = "GW_FindCombinations"
MsgBox Prompt1 & Prompt2, Style, Title

End Sub

Private Sub CalcSumVal()
DynList = Array(List(a), List(b), List(C), List(d), List
(e), List(f), List(g), List(h), _
List(i), List(j))
SumVal = Application.Sum(DynList)
End Sub
Private Sub BubbleSort(List())
'***** John Walkenback's BubbleSort procedure *****
'***** Do not remove above credit to John in your code
*****
Dim First As Integer, Last As Integer
Dim i As Integer, j As Integer
Dim Temp As Variant
First = LBound(List)
Last = UBound(List)
For i = First To Last - 1
For j = i + 1 To Last
If List(i) > List(j) Then
Temp = List(j)
List(j) = List(i)
List(i) = Temp
End If
Next j
Next i
End Sub
Private Sub MakeUF()
Dim UF As Object, Frame As Object, Ctrl As Object
Dim i As Integer, CM As Object, Line As Integer, Code As
String

Set UF = Application.VBE.ActiveVBProject.VBComponents.Add
(3)
With UF
..Properties("Height") = 175
..Properties("Width") = 160
..Properties("Caption") = "GW_FindCombinations"
End With
Set Ctrl = UF.Designer.Controls.Add("Forms.Label.1")
With Ctrl
..Width = 60
..Height = 18
..Top = 12
..Left = 10
..Caption = "Target value"
End With
Set Ctrl = UF.Designer.Controls.Add("Forms.Textbox.1")
With Ctrl
..Width = 40
..Height = 16
..Top = 10
..Left = 80
..Font.Size = 8
End With
Set Frame = UF.Designer.Controls.Add("Forms.Frame.1")
With Frame
..Width = 145
..Height = 90
..Top = 30
..Left = 5
..Caption = "Filter"
End With
For i = 1 To 5 Step 2
Set Ctrl = Frame.Controls.Add("Forms.Label.1")
With Ctrl
..Width = 70
..Height = 18
..Top = i * 12 + 2
..Left = 5
Select Case i
Case 1
..Caption = "Tolerance (±) Pct"
Case 3
..Caption = "Max. Elements"
Case 5
..Caption = "Max. Results"
End Select
End With
Next
For i = 1 To 5 Step 2
Set Ctrl = Frame.Controls.Add("Forms.Textbox.1")
With Ctrl
..Width = 35
..Height = 16
..Top = i * 12
..Left = 80
..Font.Size = 8
Select Case i
Case 1
..Text = "0.00"
Case 3
..Text = "10"
Case 5
..Text = "1000"
End Select
End With
Next

For i = 1 To 5 Step 2
Set Ctrl = Frame.Controls.Add("Forms.Spinbutton.1")
With Ctrl
..Orientation = 0
..Width = 15
..Height = 16
..Top = i * 12
..Left = 120
End With
Next

For i = 0 To 1
Set Ctrl = UF.Designer.Controls.Add
("Forms.CommandButton.1")
With Ctrl
..Width = 60
..Height = 18
..Top = 130
..Left = 12 + i * 70
If i = 0 Then .Caption = "OK" Else .Caption = "Abort"
End With
Next
Set CM = UF.CodeModule
With CM
Line = CM.CountOfLines
Code = "Private Sub SpinButton1_SpinUp()"
Code = Code & vbCr & "With TextBox2"
Code = Code & vbCr & ".Text = WorksheetFunction.Min(Val
(.Text) + 0.01, 5)"
Code = Code & vbCr & "End With"
Code = Code & vbCr & "End Sub"
Code = Code & vbCr & "Private Sub SpinButton1_SpinDown()"
Code = Code & vbCr & "With TextBox2"
Code = Code & vbCr & ".Text = WorksheetFunction.Max(Val
(.Text) - 0.01, 0)"
Code = Code & vbCr & "End With"
Code = Code & vbCr & "End Sub"
Code = Code & vbCr & "Private Sub SpinButton2_SpinUp()"
Code = Code & vbCr & "With TextBox3"
Code = Code & vbCr & ".Text = WorksheetFunction.Min(Val
(.Text) + 1, 10)"
Code = Code & vbCr & "End With"
Code = Code & vbCr & "End Sub"
Code = Code & vbCr & "Private Sub SpinButton2_SpinDown()"
Code = Code & vbCr & "With TextBox3"
Code = Code & vbCr & ".Text = WorksheetFunction.Max(Val
(.Text) - 1, 1)"
Code = Code & vbCr & "End With"
Code = Code & vbCr & "End Sub"
Code = Code & vbCr & "Private Sub SpinButton3_SpinUp()"
Code = Code & vbCr & "With TextBox4"
Code = Code & vbCr & ".Text = WorksheetFunction.Min(Val
(.Text) + 1, 1000)"
Code = Code & vbCr & "End With"
Code = Code & vbCr & "End Sub"
Code = Code & vbCr & "Private Sub SpinButton3_SpinDown()"
Code = Code & vbCr & "With TextBox4"
Code = Code & vbCr & ".Text = WorksheetFunction.Max(Val
(.Text) - 1, 1)"
Code = Code & vbCr & "End With"
Code = Code & vbCr & "End Sub"
Code = Code & vbCr & "Private Sub CommandButton1_Click()"
Code = Code & vbCr & "Target = Val(TextBox1.Text)"
Code = Code & vbCr & "Tol = TextBox1.Value * Val
(TextBox2.Text) / 100"
Code = Code & vbCr & "MaxElem = Val(TextBox3.Text)"
Code = Code & vbCr & "MaxResults = Val(TextBox4.Text)"
Code = Code & vbCr & "Unload Me"
Code = Code & vbCr & "End Sub"
Code = Code & vbCr & "Private Sub CommandButton2_Click()"
Code = Code & vbCr & "Unload Me"
Code = Code & vbCr & "End Sub"
CM.InsertLines Line + 1, Code
End With

VBA.UserForms.Add(UF.Name).Show
ThisWorkbook.VBProject.VBComponents.Remove UF
End Sub
 
D

Doug Glancy

Thanks Greg.

I'll reconstitute and try it.

Doug

Doug,

The complete code follows. Unfortunately, I can't post
through DevDex which gives me more horizontal space. The
code will be severely effected by word wrap errors. You'll
have to fix it. I had to remove all indentation to limit
word wrap.

Note:- You must first select the cells containing the
source values before running the macro. The on-the-fly UF
will allow you to input the target value and select filter
criteria. An oversight on my part is that the code does
not advise the user to first select the source data. You
might consider fixing this. It was originally designed
for decimal values such as currency. Try it under a
situation more challenging than just integers.

I use John Walkenbauch's BubbleSort procedure to sort the
array made of the selected numbers. The sorting is done
in memory - the original data is left alone. Please
maintain the credit to John in the code. Please advise of
the outcome.

Hope it goes well.

Regards,
Greg


Option Explicit
Option Base 1
Public Target As Double
Public Tol As Single
Public MaxElem As Integer
Public MaxResults As Integer

Dim List() As Variant, CumList() As Variant, DynList As
Variant
Dim SumVal As Double
Dim num As Integer, RefCell As Range
Dim a As Integer, b As Integer, C As Integer, d As Integer
Dim e As Integer, f As Integer, g As Integer, h As Integer
Dim i As Integer, j As Integer

Sub GW_FindCombinations()
Dim Prompt As String, Title As String, Style As Integer
Dim Resp As Integer, i As Integer, Cell As Range

Call MakeUF 'Create and call user form to get Target value
and filter criteria.

If Target = 0 Then Exit Sub

SumVal = 0
a = 0: b = 0: C = 0: d = 0: e = 0: f = 0: g = 0: h = 0: i
= 0: j = 0

'***** Establish number of elements in list and dimention
arrays *****
num = Selection.Cells.Count + 1 'Additional element in
list to be assigned value of zero.
ReDim List(num)
ReDim CumList(num)

'***** Exit if non-numeric value found in list else assign
selected cell values to list *****
i = 1 'Assign i an initial value of 1 so first value
assigned to array is element 2.
List(1) = 0
CumList(1) = 0
For Each Cell In Selection.Cells
If Not IsNumeric(Cell) Then
MsgBox "Error: Non-numeric value found in the selected
list. " & _
"Only numeric values allowed in list. ",
vbCritical, "Combinations Analysis"
Exit Sub
Else
i = i + 1
List(i) = Cell 'Populate List array with selected elements
leaving first element (item 0) equal to zero.
End If
Next

'***** Sort list in ascending order *****
Call BubbleSort(List())
'***** Establish CumList values as cumulative values of
selected cells *****
For i = 2 To num
CumList(i) = CumList(i - 1) + List(i)
Next

If Target = 0 Then Exit Sub
'***** Calculate maximum number of elements summed
required to exceed Target value *****
For i = 1 To num
If CumList(i) > Target + Tol Then Exit For
Next
'***** Prompt for option to specify max. number of
elements required to sum to Target value *****

If i - 2 > 10 Then
Prompt = "The macro has a limit of 10 elements that can
sum to the target value. It has been determined " & _
"that more than 10 elements from the currently selected
list can sum to " & Target & ". Therefore, you must " & _
"reduce the number of elements in the list, specify a
lower target value or accept an incomplete list of " & _
"results." & vbCr & vbCr & _
"Continue ???"
Style = vbQuestion + vbYesNo
Title = "GW_FindCombinations"
Resp = MsgBox(Prompt, Style, Title)
If Resp = vbNo Then Exit Sub
End If

If MaxElem = 0 Then
Exit Sub
Else
'Format column to right of selection to receive results.
Set RefCell = ActiveCell.Offset(, Selection.Columns.Count)
RefCell.EntireColumn.Insert
Set RefCell = RefCell.Offset(, -1)
With RefCell
..EntireColumn.HorizontalAlignment = 2
..EntireColumn.IndentLevel = 1
..Font.Bold = True
..Value = "Results for Target = " & Target
..Columns.AutoFit
End With
End If
Call MainProc

End Sub
Private Sub MainProc()
Dim z As Integer, NumElem As Integer, NumResults As Integer
Dim Nb As Integer, Nc As Integer, Nd As Integer, Ne As
Integer
Dim Nf As Integer, Ng As Integer, Nh As Integer, Ni As
Integer
Dim Nj As Integer, StartTime As Date, EndTime As Date,
Duration As Variant
Dim Prompt1 As String, Prompt2 As String
Dim Title As String, Style As Integer, Txt As String

StartTime = Now
On Error Resume Next
Application.ScreenUpdating = False

Nb = 0: Nc = 0: Nd = 0: Ne = 0: Nf = 0: Ng = 0: Nh = 0: Ni
= 0: Nj = 0
NumElem = 1

For a = 1 To num: Call CalcSumVal
If SumVal > Target + Tol Then Exit For
For b = a + Nb To num: Call CalcSumVal
If SumVal > Target + Tol Then
b = a + 2: C = a + 3: d = a + 4: e = a + 5: f = a + 6: g =
a + 7: h = a + 8: i = a + 9: j = a + 10
Exit For
End If
For C = b + Nc To num: Call CalcSumVal
If SumVal > Target + Tol Then
C = b + 2: d = b + 3: e = b + 4: f = b + 5: g = b + 6: h =
b + 7: i = b + 8: j = b + 9
Exit For
End If
For d = C + Nd To num: Call CalcSumVal
If SumVal > Target + Tol Then
d = C + 2: e = C + 3: f = C + 4: g = C + 5: h = C + 6: i =
C + 7: j = C + 8
Exit For
End If
For e = d + Ne To num: Call CalcSumVal
If SumVal > Target + Tol Then
e = d + 2: f = d + 3: g = d + 4: h = d + 5: i = d + 6: j =
d + 7
Exit For
End If
For f = e + Nf To num: Call CalcSumVal
If SumVal > Target + Tol Then
f = e + 2: g = e + 3: h = e + 4: i = e + 5: j = e + 6
Exit For
End If
For g = f + Ng To num: Call CalcSumVal
If SumVal > Target + Tol Then
g = f + 2: h = f + 3: i = f + 4: j = f + 5
Exit For
End If
For h = g + Nh To num: Call CalcSumVal
If SumVal > Target + Tol Then
h = g + 2: i = g + 3: j = g + 4
Exit For
End If
For i = h + Ni To num: Call CalcSumVal
If SumVal > Target + Tol Then
i = h + 2: j = h + 3
Exit For
End If
For j = i + Nj To num: Call CalcSumVal
If SumVal > Target + Tol Then
j = i + 2
Exit For
End If

If NumElem > MaxElem Then GoTo EndMsg

If Abs(SumVal - Target) <= Tol Then

For z = 1 To 9
If DynList(z) > 0 Then
Txt = Txt & DynList(z) & " + "
End If
Next
Txt = Txt & DynList(10) & " = " & SumVal

Set RefCell = RefCell.Offset(1)
RefCell.Value = Txt
Txt = ""
NumResults = NumResults + 1
If NumResults = MaxResults Then
MsgBox "Limit of " & MaxResults & " results reached.
Macro aborted. ", _
vbExclamation, "Combinations Analysis"
GoTo EndMsg
End If

End If

Next j: Nj = 1: NumElem = 2
Next i: Ni = 1: NumElem = 3
Next h: Nh = 1: NumElem = 4
Next g: Ng = 1: NumElem = 5
Next f: Nf = 1: NumElem = 6
Next e: Ne = 1: NumElem = 7
Next d: Nd = 1: NumElem = 8
Next C: Nc = 1: NumElem = 9
Next b: Nb = 1: NumElem = 10
Next a

EndMsg:

RefCell.EntireColumn.AutoFit

EndTime = Now
Duration = Format(EndTime - StartTime, "hh:mm:ss")
If NumResults = 0 Then
Prompt1 = "Sorry, no combinations were found that sum to "
& Target & ". " & vbCr & vbCr
Prompt2 = "Duration = " & Duration
Else
Prompt1 = "Analysis complete !!!" & vbCr & vbCr
Prompt2 = "Duration = " & Duration & vbCr & _
"Number of combinations found that sum to " & Target & "
= " & NumResults & " "
End If

Application.ScreenUpdating = True
Style = vbInformation
Title = "GW_FindCombinations"
MsgBox Prompt1 & Prompt2, Style, Title

End Sub

Private Sub CalcSumVal()
DynList = Array(List(a), List(b), List(C), List(d), List
(e), List(f), List(g), List(h), _
List(i), List(j))
SumVal = Application.Sum(DynList)
End Sub
Private Sub BubbleSort(List())
'***** John Walkenback's BubbleSort procedure *****
'***** Do not remove above credit to John in your code
*****
Dim First As Integer, Last As Integer
Dim i As Integer, j As Integer
Dim Temp As Variant
First = LBound(List)
Last = UBound(List)
For i = First To Last - 1
For j = i + 1 To Last
If List(i) > List(j) Then
Temp = List(j)
List(j) = List(i)
List(i) = Temp
End If
Next j
Next i
End Sub
Private Sub MakeUF()
Dim UF As Object, Frame As Object, Ctrl As Object
Dim i As Integer, CM As Object, Line As Integer, Code As
String

Set UF = Application.VBE.ActiveVBProject.VBComponents.Add
(3)
With UF
..Properties("Height") = 175
..Properties("Width") = 160
..Properties("Caption") = "GW_FindCombinations"
End With
Set Ctrl = UF.Designer.Controls.Add("Forms.Label.1")
With Ctrl
..Width = 60
..Height = 18
..Top = 12
..Left = 10
..Caption = "Target value"
End With
Set Ctrl = UF.Designer.Controls.Add("Forms.Textbox.1")
With Ctrl
..Width = 40
..Height = 16
..Top = 10
..Left = 80
..Font.Size = 8
End With
Set Frame = UF.Designer.Controls.Add("Forms.Frame.1")
With Frame
..Width = 145
..Height = 90
..Top = 30
..Left = 5
..Caption = "Filter"
End With
For i = 1 To 5 Step 2
Set Ctrl = Frame.Controls.Add("Forms.Label.1")
With Ctrl
..Width = 70
..Height = 18
..Top = i * 12 + 2
..Left = 5
Select Case i
Case 1
..Caption = "Tolerance (±) Pct"
Case 3
..Caption = "Max. Elements"
Case 5
..Caption = "Max. Results"
End Select
End With
Next
For i = 1 To 5 Step 2
Set Ctrl = Frame.Controls.Add("Forms.Textbox.1")
With Ctrl
..Width = 35
..Height = 16
..Top = i * 12
..Left = 80
..Font.Size = 8
Select Case i
Case 1
..Text = "0.00"
Case 3
..Text = "10"
Case 5
..Text = "1000"
End Select
End With
Next

For i = 1 To 5 Step 2
Set Ctrl = Frame.Controls.Add("Forms.Spinbutton.1")
With Ctrl
..Orientation = 0
..Width = 15
..Height = 16
..Top = i * 12
..Left = 120
End With
Next

For i = 0 To 1
Set Ctrl = UF.Designer.Controls.Add
("Forms.CommandButton.1")
With Ctrl
..Width = 60
..Height = 18
..Top = 130
..Left = 12 + i * 70
If i = 0 Then .Caption = "OK" Else .Caption = "Abort"
End With
Next
Set CM = UF.CodeModule
With CM
Line = CM.CountOfLines
Code = "Private Sub SpinButton1_SpinUp()"
Code = Code & vbCr & "With TextBox2"
Code = Code & vbCr & ".Text = WorksheetFunction.Min(Val
(.Text) + 0.01, 5)"
Code = Code & vbCr & "End With"
Code = Code & vbCr & "End Sub"
Code = Code & vbCr & "Private Sub SpinButton1_SpinDown()"
Code = Code & vbCr & "With TextBox2"
Code = Code & vbCr & ".Text = WorksheetFunction.Max(Val
(.Text) - 0.01, 0)"
Code = Code & vbCr & "End With"
Code = Code & vbCr & "End Sub"
Code = Code & vbCr & "Private Sub SpinButton2_SpinUp()"
Code = Code & vbCr & "With TextBox3"
Code = Code & vbCr & ".Text = WorksheetFunction.Min(Val
(.Text) + 1, 10)"
Code = Code & vbCr & "End With"
Code = Code & vbCr & "End Sub"
Code = Code & vbCr & "Private Sub SpinButton2_SpinDown()"
Code = Code & vbCr & "With TextBox3"
Code = Code & vbCr & ".Text = WorksheetFunction.Max(Val
(.Text) - 1, 1)"
Code = Code & vbCr & "End With"
Code = Code & vbCr & "End Sub"
Code = Code & vbCr & "Private Sub SpinButton3_SpinUp()"
Code = Code & vbCr & "With TextBox4"
Code = Code & vbCr & ".Text = WorksheetFunction.Min(Val
(.Text) + 1, 1000)"
Code = Code & vbCr & "End With"
Code = Code & vbCr & "End Sub"
Code = Code & vbCr & "Private Sub SpinButton3_SpinDown()"
Code = Code & vbCr & "With TextBox4"
Code = Code & vbCr & ".Text = WorksheetFunction.Max(Val
(.Text) - 1, 1)"
Code = Code & vbCr & "End With"
Code = Code & vbCr & "End Sub"
Code = Code & vbCr & "Private Sub CommandButton1_Click()"
Code = Code & vbCr & "Target = Val(TextBox1.Text)"
Code = Code & vbCr & "Tol = TextBox1.Value * Val
(TextBox2.Text) / 100"
Code = Code & vbCr & "MaxElem = Val(TextBox3.Text)"
Code = Code & vbCr & "MaxResults = Val(TextBox4.Text)"
Code = Code & vbCr & "Unload Me"
Code = Code & vbCr & "End Sub"
Code = Code & vbCr & "Private Sub CommandButton2_Click()"
Code = Code & vbCr & "Unload Me"
Code = Code & vbCr & "End Sub"
CM.InsertLines Line + 1, Code
End With

VBA.UserForms.Add(UF.Name).Show
ThisWorkbook.VBProject.VBComponents.Remove UF
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Remove specific cells in a column. 2
Extracting values from cells (in one column) and putting in an arr 1
How to do this kind of sorting? 3
Filling Blanks only with ABOVE nonBlanks 4
Need to add values...maybe 13
Excel VBA help: Text file formatting 19
Autofill cells in 1 column :code ?? 2
How to do this with macro? 2

Top