Tom Ogilvy - Need a little change

M

Maxi

Hi Tom,

You had given me the below code. I need a little change. Please help me
out one more time.

Now I don't need an input box for m [ m = InputBox("Taken how many at a
time?", "Combinations") ]. It will be 10 (fixed).

There is a difference in the range as well. I have the following
numbers in the range W1:AK19 (please do not change the range let it be
in W1:AK19)

4,9,10,21,35,47,64,72,74,75
4,9,10,21,33,41,47,57,60,72,74
3,4,10,11,21,32,33,35,60,69,74
3,4,7,10,21,33,37,47,57,69,75
4,7,32,37,47,57,60,64,72,74
3,7,10,11,35,47,57,60,64,66,67,72,73,79,80
4,7,9,10,11,32,35,41,69,74
3,4,10,21,32,37,47,64,69,72,75,77
3,7,11,33,35,37,41,47,64,75
4,6,9,10,15,21,31,47,72,74
6,9,13,21,22,31,49,52,63,64,75
9,10,12,21,22,47,49,52,64,72
4,6,9,12,15,35,47,56,63,72
6,9,12,15,21,31,47,64,74,75
6,9,10,13,21,49,52,63,72,74,75,79,80
4,6,13,15,35,56,63,64,74,75
13,15,21,35,47,49,56,63,72,75
4,15,42,45,47,57,60,68,72,74
10,16,28,47,51,52,55,64,71,72,74,75,76,77

I want to create combinations of the first series W1:AF1 =combin(10,1)
then below that I want to create combinations for the second series
W1:AG1 =combin(11,10) and go on listing combinations one below the
other for all the 19 series.

Total combinations should be 4411

I do not want to list these total 4411 combinations on a worksheet, I
want to send it to an array either and towards the end of the code,
just before 'End Sub" I need an input box asking me which combination
to display. If I type 34, it should display 34th element of the array
in the range AM1:AV1

Your code:

Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
numcomb = 0
Set rng = Range("A1:T1")
'Set rng = rng.Resize(1, 5)
v = Application.Transpose(Application _
.Transpose(rng))
n = UBound(v, 1)
m = InputBox("Taken how many at a time?", "Combinations")
If Application.Combin(n, m) > 64530 Then
MsgBox "Too many to write out, quitting"
Exit Sub
End If
Range("A3").Select
Comb2 n, m, 1, "'", v
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant)
Dim v1 As Variant
If m > n - k + 1 Then Exit Sub
If m = 0 Then
'Debug.Print "->" & s & "<-"
v1 = Split(Replace(Trim(s), "'", ""), " ")
For i = LBound(v1) To UBound(v1)
ActiveCell.Offset(0, i) = v(v1(i))
Next
ActiveCell.Offset(1, 0).Select
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v
Comb2 n, m, k + 1, s, v
End Sub

Thanx
Maxi
 
G

Guest

Option Explicit
Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
Dim rng1 As Range, ans As Variant
Dim irw As Long, rw As Range
Dim v1() As Long, i As Long
Dim v2() As Long, cnt As Long
Dim tot As Long, sh As Worksheet
Dim s As String
Set rng1 = Range("W1:AK19")
ReDim v1(1 To rng1.Rows.Count, 2)
i = 0
For Each rw In rng1.Rows
cnt = Application.Count(rw)
i = i + 1
v1(i, 1) = cnt
v1(i, 2) = Application.Combin(cnt, 10)
tot = tot + v1(i, 2)
Next
ReDim v2(1 To tot, 1 To 10)
i = 0
irw = 1
For Each rw In rng1.Rows
i = i + 1
cnt = v1(i, 1)
Set rng = rw.Cells.Resize(1, cnt)
v = Application.Transpose(Application _
.Transpose(rng))
n = cnt 'UBound(v, 1)
m = 10
Comb2 n, m, 1, "'", v, v2, irw
Next
Do
s = ""
ans = Application.InputBox( _
"Enter a number between " & _
"1 and " & tot & ":" & vbNewLine & _
"(Hit cancel to quit)", _
"Show Combinations", tot, _
Type:=1)
If ans = False Then Exit Do
If ans >= 1 And ans <= tot Then
For i = 1 To m
s = s & v2(ans, i) & ","
Next
s = Left(s, Len(s) - 1)
MsgBox "For row " & ans & " combinations" & _
" are: " & vbNewLine & vbNewLine & s
Else
MsgBox "Row " & ans & "doesn't exits"
End If
Loop
'
' Uncomment the next 3 lines if you want a new sheet with
' all the combinations listed on it (for validation purposes)
'
' Worksheets.Add After:=Worksheets(Worksheets.Count)
' Set sh = ActiveSheet
' sh.Range("A1").Resize(tot, 10).Value = v2
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant, _
v2() As Long, irw As Long)
Dim v1 As Variant, i As Long
If m > n - k + 1 Then Exit Sub
If m = 0 Then
v1 = Split(Replace(Trim(s), "'", ""), " ")
For i = LBound(v1) To UBound(v1)
v2(irw, i + 1) = v(v1(i))
Next
irw = irw + 1
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v, v2, irw
Comb2 n, m, k + 1, s, v, v2, irw
End Sub

--
Regards,
Tom Ogilvy


Maxi said:
Hi Tom,

You had given me the below code. I need a little change. Please help me
out one more time.

Now I don't need an input box for m [ m = InputBox("Taken how many at a
time?", "Combinations") ]. It will be 10 (fixed).

There is a difference in the range as well. I have the following
numbers in the range W1:AK19 (please do not change the range let it be
in W1:AK19)

4,9,10,21,35,47,64,72,74,75
4,9,10,21,33,41,47,57,60,72,74
3,4,10,11,21,32,33,35,60,69,74
3,4,7,10,21,33,37,47,57,69,75
4,7,32,37,47,57,60,64,72,74
3,7,10,11,35,47,57,60,64,66,67,72,73,79,80
4,7,9,10,11,32,35,41,69,74
3,4,10,21,32,37,47,64,69,72,75,77
3,7,11,33,35,37,41,47,64,75
4,6,9,10,15,21,31,47,72,74
6,9,13,21,22,31,49,52,63,64,75
9,10,12,21,22,47,49,52,64,72
4,6,9,12,15,35,47,56,63,72
6,9,12,15,21,31,47,64,74,75
6,9,10,13,21,49,52,63,72,74,75,79,80
4,6,13,15,35,56,63,64,74,75
13,15,21,35,47,49,56,63,72,75
4,15,42,45,47,57,60,68,72,74
10,16,28,47,51,52,55,64,71,72,74,75,76,77

I want to create combinations of the first series W1:AF1 =combin(10,1)
then below that I want to create combinations for the second series
W1:AG1 =combin(11,10) and go on listing combinations one below the
other for all the 19 series.

Total combinations should be 4411

I do not want to list these total 4411 combinations on a worksheet, I
want to send it to an array either and towards the end of the code,
just before 'End Sub" I need an input box asking me which combination
to display. If I type 34, it should display 34th element of the array
in the range AM1:AV1

Your code:

Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
numcomb = 0
Set rng = Range("A1:T1")
'Set rng = rng.Resize(1, 5)
v = Application.Transpose(Application _
.Transpose(rng))
n = UBound(v, 1)
m = InputBox("Taken how many at a time?", "Combinations")
If Application.Combin(n, m) > 64530 Then
MsgBox "Too many to write out, quitting"
Exit Sub
End If
Range("A3").Select
Comb2 n, m, 1, "'", v
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant)
Dim v1 As Variant
If m > n - k + 1 Then Exit Sub
If m = 0 Then
'Debug.Print "->" & s & "<-"
v1 = Split(Replace(Trim(s), "'", ""), " ")
For i = LBound(v1) To UBound(v1)
ActiveCell.Offset(0, i) = v(v1(i))
Next
ActiveCell.Offset(1, 0).Select
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v
Comb2 n, m, k + 1, s, v
End Sub

Thanx
Maxi
Click to expand...
 
M

Maxi

I need little bit of calculation/validation within the array. Check for
duplicate entries within the array and find out which element of the
array is repeated the highest number of times. I want to keep only
those elements which are repeated the highest number of times and
(highest -1) in the array and remove all other elements.

For example:
If there are elements which is repeated 4 times, then keep those
elements and also keep those which are repeated 3 times (highest -1)
and remove all other elements from the array.

If there are elements which is repeated 7 times, then keep those
elements and also keep those which are repeated 6 times (highest -1)
and remove all other elements from the array.

If there are elements which is repeated 2 times, then keep all elements
in the array and do not remove anything.

In my example, you might not get any duplicates, you might have to
change some data in the range W1:AK19 so that few duplicate entries
goes into the array.

Thanks
Maxi

Tom said:
Option Explicit
Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
Dim rng1 As Range, ans As Variant
Dim irw As Long, rw As Range
Dim v1() As Long, i As Long
Dim v2() As Long, cnt As Long
Dim tot As Long, sh As Worksheet
Dim s As String
Set rng1 = Range("W1:AK19")
ReDim v1(1 To rng1.Rows.Count, 2)
i = 0
For Each rw In rng1.Rows
cnt = Application.Count(rw)
i = i + 1
v1(i, 1) = cnt
v1(i, 2) = Application.Combin(cnt, 10)
tot = tot + v1(i, 2)
Next
ReDim v2(1 To tot, 1 To 10)
i = 0
irw = 1
For Each rw In rng1.Rows
i = i + 1
cnt = v1(i, 1)
Set rng = rw.Cells.Resize(1, cnt)
v = Application.Transpose(Application _
.Transpose(rng))
n = cnt 'UBound(v, 1)
m = 10
Comb2 n, m, 1, "'", v, v2, irw
Next
Do
s = ""
ans = Application.InputBox( _
"Enter a number between " & _
"1 and " & tot & ":" & vbNewLine & _
"(Hit cancel to quit)", _
"Show Combinations", tot, _
Type:=1)
If ans = False Then Exit Do
If ans >= 1 And ans <= tot Then
For i = 1 To m
s = s & v2(ans, i) & ","
Next
s = Left(s, Len(s) - 1)
MsgBox "For row " & ans & " combinations" & _
" are: " & vbNewLine & vbNewLine & s
Else
MsgBox "Row " & ans & "doesn't exits"
End If
Loop
'
' Uncomment the next 3 lines if you want a new sheet with
' all the combinations listed on it (for validation purposes)
'
' Worksheets.Add After:=Worksheets(Worksheets.Count)
' Set sh = ActiveSheet
' sh.Range("A1").Resize(tot, 10).Value = v2
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant, _
v2() As Long, irw As Long)
Dim v1 As Variant, i As Long
If m > n - k + 1 Then Exit Sub
If m = 0 Then
v1 = Split(Replace(Trim(s), "'", ""), " ")
For i = LBound(v1) To UBound(v1)
v2(irw, i + 1) = v(v1(i))
Next
irw = irw + 1
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v, v2, irw
Comb2 n, m, k + 1, s, v, v2, irw
End Sub

--
Regards,
Tom Ogilvy


Maxi said:
Hi Tom,

You had given me the below code. I need a little change. Please help me
out one more time.

Now I don't need an input box for m [ m = InputBox("Taken how many at a
time?", "Combinations") ]. It will be 10 (fixed).

There is a difference in the range as well. I have the following
numbers in the range W1:AK19 (please do not change the range let it be
in W1:AK19)

4,9,10,21,35,47,64,72,74,75
4,9,10,21,33,41,47,57,60,72,74
3,4,10,11,21,32,33,35,60,69,74
3,4,7,10,21,33,37,47,57,69,75
4,7,32,37,47,57,60,64,72,74
3,7,10,11,35,47,57,60,64,66,67,72,73,79,80
4,7,9,10,11,32,35,41,69,74
3,4,10,21,32,37,47,64,69,72,75,77
3,7,11,33,35,37,41,47,64,75
4,6,9,10,15,21,31,47,72,74
6,9,13,21,22,31,49,52,63,64,75
9,10,12,21,22,47,49,52,64,72
4,6,9,12,15,35,47,56,63,72
6,9,12,15,21,31,47,64,74,75
6,9,10,13,21,49,52,63,72,74,75,79,80
4,6,13,15,35,56,63,64,74,75
13,15,21,35,47,49,56,63,72,75
4,15,42,45,47,57,60,68,72,74
10,16,28,47,51,52,55,64,71,72,74,75,76,77

I want to create combinations of the first series W1:AF1 =combin(10,1)
then below that I want to create combinations for the second series
W1:AG1 =combin(11,10) and go on listing combinations one below the
other for all the 19 series.

Total combinations should be 4411

I do not want to list these total 4411 combinations on a worksheet, I
want to send it to an array either and towards the end of the code,
just before 'End Sub" I need an input box asking me which combination
to display. If I type 34, it should display 34th element of the array
in the range AM1:AV1

Your code:

Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
numcomb = 0
Set rng = Range("A1:T1")
'Set rng = rng.Resize(1, 5)
v = Application.Transpose(Application _
.Transpose(rng))
n = UBound(v, 1)
m = InputBox("Taken how many at a time?", "Combinations")
If Application.Combin(n, m) > 64530 Then
MsgBox "Too many to write out, quitting"
Exit Sub
End If
Range("A3").Select
Comb2 n, m, 1, "'", v
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant)
Dim v1 As Variant
If m > n - k + 1 Then Exit Sub
If m = 0 Then
'Debug.Print "->" & s & "<-"
v1 = Split(Replace(Trim(s), "'", ""), " ")
For i = LBound(v1) To UBound(v1)
ActiveCell.Offset(0, i) = v(v1(i))
Next
ActiveCell.Offset(1, 0).Select
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v
Comb2 n, m, k + 1, s, v
End Sub

Thanx
Maxi
Click to expand...
Click to expand...
 
T

Tom Ogilvy

Define "in the array"

The array has 4411 x 10 elements.

Are you talking about entire rows being repeated?

Are you talking about elements repeating in each single row?

Need a better definition of what you are looking for.

--
Regards,
Tom Ogilvy


Maxi said:
I need little bit of calculation/validation within the array. Check for
duplicate entries within the array and find out which element of the
array is repeated the highest number of times. I want to keep only
those elements which are repeated the highest number of times and
(highest -1) in the array and remove all other elements.

For example:
If there are elements which is repeated 4 times, then keep those
elements and also keep those which are repeated 3 times (highest -1)
and remove all other elements from the array.

If there are elements which is repeated 7 times, then keep those
elements and also keep those which are repeated 6 times (highest -1)
and remove all other elements from the array.

If there are elements which is repeated 2 times, then keep all elements
in the array and do not remove anything.

In my example, you might not get any duplicates, you might have to
change some data in the range W1:AK19 so that few duplicate entries
goes into the array.

Thanks
Maxi

Tom said:
Option Explicit
Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
Dim rng1 As Range, ans As Variant
Dim irw As Long, rw As Range
Dim v1() As Long, i As Long
Dim v2() As Long, cnt As Long
Dim tot As Long, sh As Worksheet
Dim s As String
Set rng1 = Range("W1:AK19")
ReDim v1(1 To rng1.Rows.Count, 2)
i = 0
For Each rw In rng1.Rows
cnt = Application.Count(rw)
i = i + 1
v1(i, 1) = cnt
v1(i, 2) = Application.Combin(cnt, 10)
tot = tot + v1(i, 2)
Next
ReDim v2(1 To tot, 1 To 10)
i = 0
irw = 1
For Each rw In rng1.Rows
i = i + 1
cnt = v1(i, 1)
Set rng = rw.Cells.Resize(1, cnt)
v = Application.Transpose(Application _
.Transpose(rng))
n = cnt 'UBound(v, 1)
m = 10
Comb2 n, m, 1, "'", v, v2, irw
Next
Do
s = ""
ans = Application.InputBox( _
"Enter a number between " & _
"1 and " & tot & ":" & vbNewLine & _
"(Hit cancel to quit)", _
"Show Combinations", tot, _
Type:=1)
If ans = False Then Exit Do
If ans >= 1 And ans <= tot Then
For i = 1 To m
s = s & v2(ans, i) & ","
Next
s = Left(s, Len(s) - 1)
MsgBox "For row " & ans & " combinations" & _
" are: " & vbNewLine & vbNewLine & s
Else
MsgBox "Row " & ans & "doesn't exits"
End If
Loop
'
' Uncomment the next 3 lines if you want a new sheet with
' all the combinations listed on it (for validation purposes)
'
' Worksheets.Add After:=Worksheets(Worksheets.Count)
' Set sh = ActiveSheet
' sh.Range("A1").Resize(tot, 10).Value = v2
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant, _
v2() As Long, irw As Long)
Dim v1 As Variant, i As Long
If m > n - k + 1 Then Exit Sub
If m = 0 Then
v1 = Split(Replace(Trim(s), "'", ""), " ")
For i = LBound(v1) To UBound(v1)
v2(irw, i + 1) = v(v1(i))
Next
irw = irw + 1
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v, v2, irw
Comb2 n, m, k + 1, s, v, v2, irw
End Sub

--
Regards,
Tom Ogilvy


Maxi said:
Hi Tom,

You had given me the below code. I need a little change. Please help me
out one more time.

Now I don't need an input box for m [ m = InputBox("Taken how many at a
time?", "Combinations") ]. It will be 10 (fixed).

There is a difference in the range as well. I have the following
numbers in the range W1:AK19 (please do not change the range let it be
in W1:AK19)

4,9,10,21,35,47,64,72,74,75
4,9,10,21,33,41,47,57,60,72,74
3,4,10,11,21,32,33,35,60,69,74
3,4,7,10,21,33,37,47,57,69,75
4,7,32,37,47,57,60,64,72,74
3,7,10,11,35,47,57,60,64,66,67,72,73,79,80
4,7,9,10,11,32,35,41,69,74
3,4,10,21,32,37,47,64,69,72,75,77
3,7,11,33,35,37,41,47,64,75
4,6,9,10,15,21,31,47,72,74
6,9,13,21,22,31,49,52,63,64,75
9,10,12,21,22,47,49,52,64,72
4,6,9,12,15,35,47,56,63,72
6,9,12,15,21,31,47,64,74,75
6,9,10,13,21,49,52,63,72,74,75,79,80
4,6,13,15,35,56,63,64,74,75
13,15,21,35,47,49,56,63,72,75
4,15,42,45,47,57,60,68,72,74
10,16,28,47,51,52,55,64,71,72,74,75,76,77

I want to create combinations of the first series W1:AF1 =combin(10,1)
then below that I want to create combinations for the second series
W1:AG1 =combin(11,10) and go on listing combinations one below the
other for all the 19 series.

Total combinations should be 4411

I do not want to list these total 4411 combinations on a worksheet, I
want to send it to an array either and towards the end of the code,
just before 'End Sub" I need an input box asking me which combination
to display. If I type 34, it should display 34th element of the array
in the range AM1:AV1

Your code:

Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
numcomb = 0
Set rng = Range("A1:T1")
'Set rng = rng.Resize(1, 5)
v = Application.Transpose(Application _
.Transpose(rng))
n = UBound(v, 1)
m = InputBox("Taken how many at a time?", "Combinations")
If Application.Combin(n, m) > 64530 Then
MsgBox "Too many to write out, quitting"
Exit Sub
End If
Range("A3").Select
Comb2 n, m, 1, "'", v
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant)
Dim v1 As Variant
If m > n - k + 1 Then Exit Sub
If m = 0 Then
'Debug.Print "->" & s & "<-"
v1 = Split(Replace(Trim(s), "'", ""), " ")
For i = LBound(v1) To UBound(v1)
ActiveCell.Offset(0, i) = v(v1(i))
Next
ActiveCell.Offset(1, 0).Select
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v
Comb2 n, m, k + 1, s, v
End Sub

Thanx
Maxi
Click to expand...
Click to expand...
Click to expand...
 
M

Maxi

Sorry about the confusion. I mean 1 X 10 being repeated (the entire
row).

eg.
1,2,3,4,5,6,7,8,9,10
1,2,3,4,5,6,7,8,9,11
1,2,3,4,5,6,7,8,9,10
1,2,3,4,5,6,7,8,9,12
1,2,3,4,5,6,7,8,9,10

1,2,3,4,5,6,7,8,9,10 : repeated thrice

Tom said:
Define "in the array"

The array has 4411 x 10 elements.

Are you talking about entire rows being repeated?

Are you talking about elements repeating in each single row?

Need a better definition of what you are looking for.

--
Regards,
Tom Ogilvy


Maxi said:
I need little bit of calculation/validation within the array. Check for
duplicate entries within the array and find out which element of the
array is repeated the highest number of times. I want to keep only
those elements which are repeated the highest number of times and
(highest -1) in the array and remove all other elements.

For example:
If there are elements which is repeated 4 times, then keep those
elements and also keep those which are repeated 3 times (highest -1)
and remove all other elements from the array.

If there are elements which is repeated 7 times, then keep those
elements and also keep those which are repeated 6 times (highest -1)
and remove all other elements from the array.

If there are elements which is repeated 2 times, then keep all elements
in the array and do not remove anything.

In my example, you might not get any duplicates, you might have to
change some data in the range W1:AK19 so that few duplicate entries
goes into the array.

Thanks
Maxi

Tom said:
Option Explicit
Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
Dim rng1 As Range, ans As Variant
Dim irw As Long, rw As Range
Dim v1() As Long, i As Long
Dim v2() As Long, cnt As Long
Dim tot As Long, sh As Worksheet
Dim s As String
Set rng1 = Range("W1:AK19")
ReDim v1(1 To rng1.Rows.Count, 2)
i = 0
For Each rw In rng1.Rows
cnt = Application.Count(rw)
i = i + 1
v1(i, 1) = cnt
v1(i, 2) = Application.Combin(cnt, 10)
tot = tot + v1(i, 2)
Next
ReDim v2(1 To tot, 1 To 10)
i = 0
irw = 1
For Each rw In rng1.Rows
i = i + 1
cnt = v1(i, 1)
Set rng = rw.Cells.Resize(1, cnt)
v = Application.Transpose(Application _
.Transpose(rng))
n = cnt 'UBound(v, 1)
m = 10
Comb2 n, m, 1, "'", v, v2, irw
Next
Do
s = ""
ans = Application.InputBox( _
"Enter a number between " & _
"1 and " & tot & ":" & vbNewLine & _
"(Hit cancel to quit)", _
"Show Combinations", tot, _
Type:=1)
If ans = False Then Exit Do
If ans >= 1 And ans <= tot Then
For i = 1 To m
s = s & v2(ans, i) & ","
Next
s = Left(s, Len(s) - 1)
MsgBox "For row " & ans & " combinations" & _
" are: " & vbNewLine & vbNewLine & s
Else
MsgBox "Row " & ans & "doesn't exits"
End If
Loop
'
' Uncomment the next 3 lines if you want a new sheet with
' all the combinations listed on it (for validation purposes)
'
' Worksheets.Add After:=Worksheets(Worksheets.Count)
' Set sh = ActiveSheet
' sh.Range("A1").Resize(tot, 10).Value = v2
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant, _
v2() As Long, irw As Long)
Dim v1 As Variant, i As Long
If m > n - k + 1 Then Exit Sub
If m = 0 Then
v1 = Split(Replace(Trim(s), "'", ""), " ")
For i = LBound(v1) To UBound(v1)
v2(irw, i + 1) = v(v1(i))
Next
irw = irw + 1
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v, v2, irw
Comb2 n, m, k + 1, s, v, v2, irw
End Sub

--
Regards,
Tom Ogilvy


:

Hi Tom,

You had given me the below code. I need a little change. Please help me
out one more time.

Now I don't need an input box for m [ m = InputBox("Taken how many at a
time?", "Combinations") ]. It will be 10 (fixed).

There is a difference in the range as well. I have the following
numbers in the range W1:AK19 (please do not change the range let it be
in W1:AK19)

4,9,10,21,35,47,64,72,74,75
4,9,10,21,33,41,47,57,60,72,74
3,4,10,11,21,32,33,35,60,69,74
3,4,7,10,21,33,37,47,57,69,75
4,7,32,37,47,57,60,64,72,74
3,7,10,11,35,47,57,60,64,66,67,72,73,79,80
4,7,9,10,11,32,35,41,69,74
3,4,10,21,32,37,47,64,69,72,75,77
3,7,11,33,35,37,41,47,64,75
4,6,9,10,15,21,31,47,72,74
6,9,13,21,22,31,49,52,63,64,75
9,10,12,21,22,47,49,52,64,72
4,6,9,12,15,35,47,56,63,72
6,9,12,15,21,31,47,64,74,75
6,9,10,13,21,49,52,63,72,74,75,79,80
4,6,13,15,35,56,63,64,74,75
13,15,21,35,47,49,56,63,72,75
4,15,42,45,47,57,60,68,72,74
10,16,28,47,51,52,55,64,71,72,74,75,76,77

I want to create combinations of the first series W1:AF1 =combin(10,1)
then below that I want to create combinations for the second series
W1:AG1 =combin(11,10) and go on listing combinations one below the
other for all the 19 series.

Total combinations should be 4411

I do not want to list these total 4411 combinations on a worksheet, I
want to send it to an array either and towards the end of the code,
just before 'End Sub" I need an input box asking me which combination
to display. If I type 34, it should display 34th element of the array
in the range AM1:AV1

Your code:

Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
numcomb = 0
Set rng = Range("A1:T1")
'Set rng = rng.Resize(1, 5)
v = Application.Transpose(Application _
.Transpose(rng))
n = UBound(v, 1)
m = InputBox("Taken how many at a time?", "Combinations")
If Application.Combin(n, m) > 64530 Then
MsgBox "Too many to write out, quitting"
Exit Sub
End If
Range("A3").Select
Comb2 n, m, 1, "'", v
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant)
Dim v1 As Variant
If m > n - k + 1 Then Exit Sub
If m = 0 Then
'Debug.Print "->" & s & "<-"
v1 = Split(Replace(Trim(s), "'", ""), " ")
For i = LBound(v1) To UBound(v1)
ActiveCell.Offset(0, i) = v(v1(i))
Next
ActiveCell.Offset(1, 0).Select
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v
Comb2 n, m, k + 1, s, v
End Sub

Thanx
Maxi
Click to expand...
Click to expand...
Click to expand...
 
T

Tom Ogilvy

this is an intermediate result. on the added sheet, you will see your 4411
rows with each combination in columnA (each value occupies 3 digits - so 30
digits. This list is sorted
Column B holds the index location from the original array
Column C holds the a sequence counter for matches. the first record in a
matching sequence will have a 1, the second a 2 and so forth
Column D will show the max value in that sequence. So for 6 matching rows,
for the first row, column C: 1, column D: 6; for the second matching row
Column C: 2, Column D: 6 until both column C and D contain 6.

Column F, starting in row 1 is numbered 1 to the highest number of
duplicates
Column G corresponds to F and lists the number of duplicate sets for the
number in F on the same row

Column I has Column A repeated except the rows that don't have the maximum
or the maximum -1 in the set are blank
Column J is the same as Column B, so you have an index into the original
array


If the max number is 3 of duplicates is 3, assume that any sets with 2
duplicates would be retained

If there are m number of unique combinations that have the maximum number of
duplicates and m1 number of unique combinations that have the (maximum - 1)
number of duplicates, are these all left and everything else cleared?

So what now. How do you want it packaged.
leave it in the array. Should the original array be compressed down so
there are no empty rows?

Just for info, I did 266 rows (duplicating a modified version of your data
of 19 rows) and generated a 61K x 10 array of combinations. This processed
in less than 10 seconds on my machine.


Option Explicit
Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
Dim rng1 As Range, ans As Variant
Dim irw As Long, rw As Range
Dim v1() As Long, i As Long
Dim v2() As Long, cnt As Long
Dim v3() As Variant, lMax As Long
Dim v4() As Long
Dim tot As Long, sh As Worksheet
Dim s As String, bAscending As Boolean
'Set rng1 = Range("W1:AK19")
Set rng1 = Range("W1:AK38")
ReDim v1(1 To rng1.Rows.Count, 2)
i = 0
For Each rw In rng1.Rows
cnt = Application.Count(rw)
i = i + 1
v1(i, 1) = cnt
v1(i, 2) = Application.Combin(cnt, 10)
tot = tot + v1(i, 2)
Next
ReDim v2(1 To tot, 1 To 10)
ReDim v3(1 To tot, 1 To 5)
i = 0
irw = 1
For Each rw In rng1.Rows
i = i + 1
cnt = v1(i, 1)
Set rng = rw.Cells.Resize(1, cnt)
v = Application.Transpose(Application _
.Transpose(rng))
n = cnt 'UBound(v, 1)
m = 10
Comb2 n, m, 1, "'", v, v2, v3, irw
Next
Do
s = ""
ans = Application.InputBox( _
"Enter a number between " & _
"1 and " & tot & ":" & vbNewLine & _
"(Hit cancel to quit)", _
"Show Combinations", tot, _
Type:=1)
If ans = False Then Exit Do
If ans >= 1 And ans <= tot Then
For i = 1 To m
s = s & v2(ans, i) & ","
Next
s = Left(s, Len(s) - 1)
MsgBox "For row " & ans & " combinations" & _
" are: " & vbNewLine & vbNewLine & s
Else
MsgBox "Row " & ans & "doesn't exits"
End If
Loop
'
' Uncomment the next 3 lines if you want a new sheet with
' all the combinations listed on it (for validation purposes)
'
bAscending = True
QuickSort v3, 1, LBound(v3, 1), UBound(v3, 1), bAscending
lMax = 1
v3(1, 3) = 1
For i = 2 To UBound(v3, 1)
If StrComp(v3(i, 1), v3(i - 1, 1), vbBinaryCompare) > 0 Then
v3(i, 3) = 1
Else
v3(i, 3) = v3(i - 1, 3) + 1
End If
If v3(i, 3) > lMax Then lMax = v3(i, 3)
Next
ReDim v4(1 To lMax)

v3(UBound(v3, 1), 4) = v3(UBound(v3, 1), 3)
v4(v3(UBound(v3, 1), 4)) = 1

For i = UBound(v3, 1) - 1 To 1 Step -1
If v3(i, 3) < v3(i + 1, 3) Then
v3(i, 4) = v3(i + 1, 4)
Else
v3(i, 4) = v3(i, 3)
v4(v3(i, 4)) = v4(v3(i, 4)) + 1
End If
Next
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
' sh.Range("A1").Resize(tot, 10).Value = v2
sh.Range("A1").Resize(tot, 5).Value = v3
sh.Range("G1").Resize(lMax, 1).Value = _
Application.Transpose(v4)
For i = 1 To lMax
sh.Cells(i, "F").Value = i
Next
If lMax > 2 Then
For i = 1 To tot
If v3(i, 4) <> lMax And v3(i, 4) <> lMax - 1 Then
v3(i, 1) = Empty
End If
Next
sh.Range("I1").Resize(tot, 5).Value = v3
sh.Columns(11).Resize(, 3).Delete
If IsEmpty(sh.Range("I1")) Then sh.Range("I1").End(xlDown).Select
End If
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant, _
v2() As Long, v3() As Variant, irw As Long)
Dim v1 As Variant, i As Long, s1 As String
If m > n - k + 1 Then Exit Sub
If m = 0 Then
v1 = Split(Replace(Trim(s), "'", ""), " ")
s1 = "'"
For i = LBound(v1) To UBound(v1)
v2(irw, i + 1) = v(v1(i))
s1 = s1 & Format(v(v1(i)), "000")
Next
v3(irw, 1) = s1
v3(irw, 2) = irw
irw = irw + 1
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v, v2, v3, irw
Comb2 n, m, k + 1, s, v, v2, v3, irw
End Sub


Sub QuickSort(SortArray, col, L, R, bAscending)
'
'Originally Posted by Jim Rech 10/20/98 Excel.Programming
'Modified to sort on first column of a two dimensional array
'Modified to handle a second dimension greater than 1 (or zero)
'Modified to sort on a specified column in a 2D array
'Modified to do Ascending or Descending
Dim i, j, X, Y, mm

i = L
j = R
X = SortArray((L + R) / 2, col)
If bAscending Then
While (i <= j)
While (SortArray(i, col) < X And i < R)
i = i + 1
Wend
While (X < SortArray(j, col) And j > L)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
Else
While (i <= j)
While (SortArray(i, col) > X And i < R)
i = i + 1
Wend
While (X > SortArray(j, col) And j > L)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
End If
If (L < j) Then Call QuickSort(SortArray, col, L, j, bAscending)
If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)
End Sub
 
M

Maxi

Hi! Tom,

Great solution, thank you very much. The explanation given was
wonderful and easy to understand.

Your question "If there are m number of unique combinations that have
the maximum number of duplicates and m1 number of unique combinations
that have the (maximum - 1) number of duplicates, are these all left
and everything else cleared?"

Answer is "YES"

Answering your other question "So what now. How do you want it
packaged?" Here is the answer:

Earlier with the data provided, I was getting 4411 combinations. If I
change my data to the data given below, I get 10413 combinations out of
which 1001 combinations are repeated 4 times and 1 combination is
repeated 3 times (maximum frequency -1). I ran your code to get this
result and I also did it manually to verify the results which are
correct. Hats off to you. Now I want to keep these 1002 (1001 [freq=4]
+ 1 [freq=3]) in a the array and remove all other entries (freq=1 and
freq=2) and all other empty rows (if any).

I have two more questions:

1. With a small data given earlier with 4411 combinations or with this
new data where there are 10413 combinations, it is okay to have an
intermediate result on the added worksheet. I am wondering if the total
combinations goes beyond 65536 then what? My question is instead of
having the intermediate result on the worksheet, can it be kept within
the array so that the worksheet never overflows?

2. Sometimes I get an error with a title "Windows - Virtual Memory
Minimum Too Low" Your system is low on virtual memory. Windows is
increasing the size of your virutal memory paging file. During this
process, memory requests for some applications may be denied. For more
information, see Help." Is this happenning because there is lot of data
in the 2D array? If yes, can it be erased once the module is finished
running and the results are stored in the worksheet? What is the best
way to resolve this issue?

The reason why I am asking this is because, in my real data, the
resulting combinations (in this example it is 4411 and 10413) can go
upto a maximum of 5000000.

More info on my system:
I have Intel Pentium Celeron processor 800 Mhz with 256 MB SDRAM 300
Mhz. Total paging file size for all drives is set to 384 MB. In the
virual memory window, under Custom Size, Initial size is set to 384 MB
and Maximum size is set to 768. I got this info from Right click My
Computer -> Properties -> Advanced tab -> Settings button (under
Performance) -> Advanced tab -> Change button.

Here is the new data to try out where there are 10413 combinations

4,9,10,21,35,47,64,72,74,75
4,9,10,21,33,41,47,57,60,72,74
3,4,10,11,21,32,33,35,60,69,74
3,4,7,10,21,33,37,47,57,69,75
3,7,10,11,35,47,57,60,64,66,67,72,73,79,80
3,7,10,11,35,47,57,60,64,66,67,72,73,79,80
4,7,9,10,11,32,35,41,69,74
3,4,10,21,32,37,47,64,69,72,75,77
3,7,11,33,35,37,41,47,64,75
4,6,9,10,15,21,31,47,72,74
6,9,13,21,22,31,49,52,63,64,75
9,10,12,21,22,47,49,52,64,72
9,10,12,21,22,47,49,52,64,72
9,10,12,21,22,47,49,52,64,72
6,9,10,13,21,49,52,63,72,74,75,79,80,
10,16,28,47,51,52,55,64,71,72,74,75,76,77
10,16,28,47,51,52,55,64,71,72,74,75,76,77
10,16,28,47,51,52,55,64,71,72,74,75,76,77
10,16,28,47,51,52,55,64,71,72,74,75,76,77

Thanks,
Maxi
 
T

Tom Ogilvy

The data always was in an array. I just put it on the worksheet so you can
see it.

In this new version, I still write it to the sheet for examination (which
can be suppressed), but the data remains in the array V3a for your use

with your new data, v3a is 4007 x 10 made up of the 4 and 3 duplicates.

You can just change the bPrintout variable to false down near the bottom of
the Combinations routine if you want to suppress writing of the sheet.

Option Explicit

Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
Dim rng1 As Range, ans As Variant
Dim irw As Long, rw As Range
Dim v1() As Long, i As Long
Dim lMax As Long, cnt As Long
Dim v2a() As Variant, ii As Long
Dim v3a() As Long, j As Long
Dim bDone As Boolean
Dim bPrintout as Boolean

Dim tot As Long, sh As Worksheet
Dim s As String, bAscending As Boolean
Set rng1 = Range("W1:AK19")
ReDim v1(1 To rng1.Rows.Count, 2)
i = 0
For Each rw In rng1.Rows
cnt = Application.Count(rw)
i = i + 1
v1(i, 1) = cnt
v1(i, 2) = Application.Combin(cnt, 10)
tot = tot + v1(i, 2)
Next
ReDim v2a(1 To tot, 1 To 2)
ReDim v3a(1 To tot)
i = 0
irw = 1
For Each rw In rng1.Rows
i = i + 1
cnt = v1(i, 1)
Set rng = rw.Cells.Resize(1, cnt)
v = Application.Transpose(Application _
.Transpose(rng))
n = cnt 'UBound(v, 1)
m = 10
Comb2 n, m, 1, "'", v, v2a, irw

Next


'
bAscending = True
QuickSort v2a, 1, LBound(v2a, 1), UBound(v2a, 1), bAscending

lMax = 1
v2a(1, 2) = 1
For i = 2 To UBound(v3a, 1)
If StrComp(v2a(i, 1), v2a(i - 1, 1), vbBinaryCompare) > 0 Then
ii = v2a(i - 1, 2)
For j = i - v2a(i - 1, 2) To i - 1
v2a(j, 2) = ii
Next
v2a(i, 2) = 1
Else
v2a(i, 2) = v2a(i - 1, 2) + 1
End If
If v2a(i, 2) > lMax Then lMax = v2a(i, 2)
Next
i = UBound(v2a) + 1
ii = v2a(i - 1, 2)
For j = i - v2a(i - 1, 2) To i - 1
v2a(j, 2) = ii
Next


cnt = 0
If lMax > 2 Then
For i = 1 To tot
If v2a(i, 2) <> lMax And v2a(i, 2) <> lMax - 1 Then
v2a(i, 1) = Empty
Else
cnt = cnt + 1
End If
Next
ReDim v3a(1 To cnt, 1 To 10)
cnt = 0

For i = 1 To tot
If Not IsEmpty(v2a(i, 1)) Then
cnt = cnt + 1
s = Right(v2a(i, 1), 20)
For j = 1 To 20 Step 2
v3a(cnt, (j + 1) / 2) = CLng(Mid(s, j, 2))
Next j
End If
Next i

' data you want is now in v3a


' change bPrintout to False if you don't want to write a sheet to
' assist in examining the results

bPrintout = True
if bPrintout then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
sh.Range("A1").Resize(tot, 2) = v2a
sh.Range("D1").Resize(cnt, 10).Value = v3a
End If
End if

Erase v2a

End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant, _
v2a() As Variant, irw As Long)
Dim v1 As Variant, i As Long, s1 As String, s2 As String
If m > n - k + 1 Then Exit Sub
If m = 0 Then
v1 = Split(Replace(Trim(s), "'", ""), " ")
s2 = "'"
For i = LBound(v1) To UBound(v1)
s2 = s2 & Format(v(v1(i)), "00")
Next
v2a(irw, 1) = s2
irw = irw + 1
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v, v2a, irw
Comb2 n, m, k + 1, s, v, v2a, irw
End Sub


Sub QuickSort(SortArray, col, L, R, bAscending)
'
'Originally Posted by Jim Rech 10/20/98 Excel.Programming
'Modified to sort on first column of a two dimensional array
'Modified to handle a second dimension greater than 1 (or zero)
'Modified to sort on a specified column in a 2D array
'Modified to do Ascending or Descending
Dim i, j, X, Y, mm

i = L
j = R
X = SortArray((L + R) / 2, col)
If bAscending Then
While (i <= j)
While (SortArray(i, col) < X And i < R)
i = i + 1
Wend
While (X < SortArray(j, col) And j > L)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
Else
While (i <= j)
While (SortArray(i, col) > X And i < R)
i = i + 1
Wend
While (X > SortArray(j, col) And j > L)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
End If
If (L < j) Then Call QuickSort(SortArray, col, L, j, bAscending)
If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)
End Sub

--
Regards,
Tom Ogilvy



Maxi said:
Hi! Tom,

Great solution, thank you very much. The explanation given was
wonderful and easy to understand.

Your question "If there are m number of unique combinations that have
the maximum number of duplicates and m1 number of unique combinations
that have the (maximum - 1) number of duplicates, are these all left
and everything else cleared?"

Answer is "YES"

Answering your other question "So what now. How do you want it
packaged?" Here is the answer:

Earlier with the data provided, I was getting 4411 combinations. If I
change my data to the data given below, I get 10413 combinations out of
which 1001 combinations are repeated 4 times and 1 combination is
repeated 3 times (maximum frequency -1). I ran your code to get this
result and I also did it manually to verify the results which are
correct. Hats off to you. Now I want to keep these 1002 (1001 [freq=4]
+ 1 [freq=3]) in a the array and remove all other entries (freq=1 and
freq=2) and all other empty rows (if any).

I have two more questions:

1. With a small data given earlier with 4411 combinations or with this
new data where there are 10413 combinations, it is okay to have an
intermediate result on the added worksheet. I am wondering if the total
combinations goes beyond 65536 then what? My question is instead of
having the intermediate result on the worksheet, can it be kept within
the array so that the worksheet never overflows?

2. Sometimes I get an error with a title "Windows - Virtual Memory
Minimum Too Low" Your system is low on virtual memory. Windows is
increasing the size of your virutal memory paging file. During this
process, memory requests for some applications may be denied. For more
information, see Help." Is this happenning because there is lot of data
in the 2D array? If yes, can it be erased once the module is finished
running and the results are stored in the worksheet? What is the best
way to resolve this issue?

The reason why I am asking this is because, in my real data, the
resulting combinations (in this example it is 4411 and 10413) can go
upto a maximum of 5000000.

More info on my system:
I have Intel Pentium Celeron processor 800 Mhz with 256 MB SDRAM 300
Mhz. Total paging file size for all drives is set to 384 MB. In the
virual memory window, under Custom Size, Initial size is set to 384 MB
and Maximum size is set to 768. I got this info from Right click My
Computer -> Properties -> Advanced tab -> Settings button (under
Performance) -> Advanced tab -> Change button.

Here is the new data to try out where there are 10413 combinations

4,9,10,21,35,47,64,72,74,75
4,9,10,21,33,41,47,57,60,72,74
3,4,10,11,21,32,33,35,60,69,74
3,4,7,10,21,33,37,47,57,69,75
3,7,10,11,35,47,57,60,64,66,67,72,73,79,80
3,7,10,11,35,47,57,60,64,66,67,72,73,79,80
4,7,9,10,11,32,35,41,69,74
3,4,10,21,32,37,47,64,69,72,75,77
3,7,11,33,35,37,41,47,64,75
4,6,9,10,15,21,31,47,72,74
6,9,13,21,22,31,49,52,63,64,75
9,10,12,21,22,47,49,52,64,72
9,10,12,21,22,47,49,52,64,72
9,10,12,21,22,47,49,52,64,72
6,9,10,13,21,49,52,63,72,74,75,79,80,
10,16,28,47,51,52,55,64,71,72,74,75,76,77
10,16,28,47,51,52,55,64,71,72,74,75,76,77
10,16,28,47,51,52,55,64,71,72,74,75,76,77
10,16,28,47,51,52,55,64,71,72,74,75,76,77

Thanks,
Maxi
Click to expand...
 
M

Maxi

Hi! Tom,

I ran the suppressed version of the code and I got the 4007 x 10
result of the array v3a in the range D1:M4007. Actually I only wanted
1002 combinations (eliminating the duplicates within the frequency 3
and 4). Currently the code is showing (1001 x 4 = 4004 [freq=4]) and
(1 x 3 = 3 [Freq=3] ) which is 4004+3=4007 and I need only 1002.

Moreover, to take the summary of the entire conversation:

In the first step, we created all possible combinations of the 17 rows
present in the range W1:AK19. Answer was 10413 taking into
consideration the new data I provided.

In the second step, we narrowed down those 10413 combinations such that
only combinations with highest frequency and frequency - 1 is left out
in the array. Answer: The total combinations were narrowed down to
1002. (But currently it is showing 4007 that needs to be rectified)

In the LAST step, I want to perform few calculations on these narrowed
down 1002 combinations and list them with a SUPPORTING VALUE. This
SUPPORTING VALUE will be a variable or a new array. This is the final
request from me.

Here is the question for the LAST step:
---------------------------

Following is a table that I want to use for calculating the SUPPORTING
VALUE
4 10
5 30
6 120
7 1000
8 11000
9 80000
10 2000000

Following is the data I have in the range A1:T3
10,12,16,21,22,24,26,27,29,33,47,49,52,54,57,60,61,62,67,72
1,2,5,8,9,10,16,28,30,33,34,39,42,47,51,52,55,64,78,79
3,4,6,10,16,28,31,32,35,40,41,46,47,51,52,55,64,71,74,80

Question:
Pick up first combination from the narrowed down 1002 combinations
(which is 9 10 12 21 22 47 49 52 64 72) and check how many number
matched in the range A1:T1. In this example, 8 numbers matched (10 12
21 22 47 49 52 72). Now look at the table, the corresponding value for
8 is 11000 therefore assign 11000 to the SUPPORTING VALUE. Move to
range A2:T2. 5 numbers matched (9 10 47 52 64). Correspondng value for
5 in the table is 30 now add this to the current SUPPORTING VALUE
(11000+30). Move to the next range A3:T3. 4 numbers matched (10 47 52
64) corresponding value for 4 is 10. Add this to the current SUPPORTING
VALUE (11000+30+10). Hence the SUPPORTING VALUE for the first
combination would become 11040 (11000+30+10).

Perform this calculation for all 1002 combinations. Sort the entire
combinations on the SUPPORTING VALUE in descending order.

** We should get a result like this: **
C1,C2,C3,C4,C5,C6,C7,C8,C9,C10 | SUPPORTING VALUE
10,16,28,47,51,52,55,64,71,74 | 2011000
10,16,28,47,51,52,55,64,71,72 | 91010
10,16,28,47,51,52,55,64,72,74 | 91010
10,16,28,47,51,52,55,64,71,75 | 91000
10,16,28,47,51,52,55,64,71,75 | 91000
10,16,28,47,51,52,55,64,71,76 | 91000
10,16,28,47,51,52,55,64,71,77 | 91000
10,16,28,47,51,52,55,64,74,75 | 91000
10,16,28,47,51,52,55,64,74,76 | 91000
10,16,28,47,51,52,55,64,74,77 | 91000
10,16,28,47,51,52,55,71,72,74 | 81010
10,16,28,47,51,52,64,71,72,74 | 81010
10,16,28,47,52,55,64,71,72,74 | 81010
10,16,47,51,52,55,64,71,72,74 | 81010
16,28,47,51,52,55,64,71,72,74 | 81010
10,16,28,47,51,52,55,71,74,75 | 81000

Note: Use the new data that I provided which gives 10413 combinations.
Once this is done, I don't want to keep anything in the array. Just
list it on the worksheet.

Thank you
Maxi
 
T

Tom Ogilvy

My oversight,
Here is the code to give the 1002, it will probably be a couple days before
I have a chance to look at the rest.

Option Explicit

Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
Dim rng1 As Range, ans As Variant
Dim irw As Long, rw As Range
Dim v1() As Long, i As Long
Dim lMax As Long, cnt As Long
Dim v2a() As Variant, ii As Long
Dim v3a() As Long, j As Long
Dim bDone As Boolean
Dim bPrintout As Boolean

Dim tot As Long, sh As Worksheet
Dim s As String, bAscending As Boolean
Set rng1 = Range("W1:AK19")
ReDim v1(1 To rng1.Rows.Count, 2)
i = 0
For Each rw In rng1.Rows
cnt = Application.Count(rw)
i = i + 1
v1(i, 1) = cnt
v1(i, 2) = Application.Combin(cnt, 10)
tot = tot + v1(i, 2)
Next
ReDim v2a(1 To tot, 1 To 3)
ReDim v3a(1 To tot)
i = 0
irw = 1
For Each rw In rng1.Rows
i = i + 1
cnt = v1(i, 1)
Set rng = rw.Cells.Resize(1, cnt)
v = Application.Transpose(Application _
.Transpose(rng))
n = cnt 'UBound(v, 1)
m = 10
Comb2 n, m, 1, "'", v, v2a, irw

Next


'
bAscending = True
QuickSort v2a, 1, LBound(v2a, 1), UBound(v2a, 1), bAscending

lMax = 1
v2a(1, 2) = 1
For i = 2 To UBound(v2a, 1)
If StrComp(v2a(i, 1), v2a(i - 1, 1), vbBinaryCompare) > 0 Then
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next
v2a(i, 2) = 1
Else
v2a(i, 2) = v2a(i - 1, 2) + 1
End If
If v2a(i, 2) > lMax Then lMax = v2a(i, 2)
Next
i = UBound(v2a) + 1
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next


cnt = 0
If lMax > 2 Then
For i = 1 To tot
If v2a(i, 3) <> lMax And v2a(i, 3) <> lMax - 1 Then
v2a(i, 1) = Empty
Else
If v2a(i, 2) = 1 Then
cnt = cnt + 1
End If
End If
Next
ReDim v3a(1 To cnt, 1 To 10)
cnt = 0

For i = 1 To tot
If Not IsEmpty(v2a(i, 1)) Then
If v2a(i, 2) = 1 Then
cnt = cnt + 1
s = Right(v2a(i, 1), 20)
For j = 1 To 20 Step 2
v3a(cnt, (j + 1) / 2) = CLng(Mid(s, j, 2))
Next j
End If
End If
Next i

' data you want is now in v3a


' change bPrintout to False if you don't want to write a sheet to
' assist in examining the results

bPrintout = True
If bPrintout Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
sh.Range("A1").Resize(tot, 2) = v2a
sh.Range("D1").Resize(cnt, 10).Value = v3a
End If
End If

Erase v2a

End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant, _
v2a() As Variant, irw As Long)
Dim v1 As Variant, i As Long, s1 As String, s2 As String
If m > n - k + 1 Then Exit Sub
If m = 0 Then
v1 = Split(Replace(Trim(s), "'", ""), " ")
s2 = "'"
For i = LBound(v1) To UBound(v1)
s2 = s2 & Format(v(v1(i)), "00")
Next
v2a(irw, 1) = s2
irw = irw + 1
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v, v2a, irw
Comb2 n, m, k + 1, s, v, v2a, irw
End Sub


Sub QuickSort(SortArray, col, L, R, bAscending)
'
'Originally Posted by Jim Rech 10/20/98 Excel.Programming
'Modified to sort on first column of a two dimensional array
'Modified to handle a second dimension greater than 1 (or zero)
'Modified to sort on a specified column in a 2D array
'Modified to do Ascending or Descending
Dim i, j, X, Y, mm

i = L
j = R
X = SortArray((L + R) / 2, col)
If bAscending Then
While (i <= j)
While (SortArray(i, col) < X And i < R)
i = i + 1
Wend
While (X < SortArray(j, col) And j > L)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
Else
While (i <= j)
While (SortArray(i, col) > X And i < R)
i = i + 1
Wend
While (X > SortArray(j, col) And j > L)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
End If
If (L < j) Then Call QuickSort(SortArray, col, L, j, bAscending)
If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)
End Sub

--
Regards,
Tom Ogilvy

Maxi said:
Hi! Tom,

I ran the suppressed version of the code and I got the 4007 x 10
result of the array v3a in the range D1:M4007. Actually I only wanted
1002 combinations (eliminating the duplicates within the frequency 3
and 4). Currently the code is showing (1001 x 4 = 4004 [freq=4]) and
(1 x 3 = 3 [Freq=3] ) which is 4004+3=4007 and I need only 1002.

Moreover, to take the summary of the entire conversation:

In the first step, we created all possible combinations of the 17 rows
present in the range W1:AK19. Answer was 10413 taking into
consideration the new data I provided.

In the second step, we narrowed down those 10413 combinations such that
only combinations with highest frequency and frequency - 1 is left out
in the array. Answer: The total combinations were narrowed down to
1002. (But currently it is showing 4007 that needs to be rectified)

In the LAST step, I want to perform few calculations on these narrowed
down 1002 combinations and list them with a SUPPORTING VALUE. This
SUPPORTING VALUE will be a variable or a new array. This is the final
request from me.

Here is the question for the LAST step:
---------------------------

Following is a table that I want to use for calculating the SUPPORTING
VALUE
4 10
5 30
6 120
7 1000
8 11000
9 80000
10 2000000

Following is the data I have in the range A1:T3
10,12,16,21,22,24,26,27,29,33,47,49,52,54,57,60,61,62,67,72
1,2,5,8,9,10,16,28,30,33,34,39,42,47,51,52,55,64,78,79
3,4,6,10,16,28,31,32,35,40,41,46,47,51,52,55,64,71,74,80

Question:
Pick up first combination from the narrowed down 1002 combinations
(which is 9 10 12 21 22 47 49 52 64 72) and check how many number
matched in the range A1:T1. In this example, 8 numbers matched (10 12
21 22 47 49 52 72). Now look at the table, the corresponding value for
8 is 11000 therefore assign 11000 to the SUPPORTING VALUE. Move to
range A2:T2. 5 numbers matched (9 10 47 52 64). Correspondng value for
5 in the table is 30 now add this to the current SUPPORTING VALUE
(11000+30). Move to the next range A3:T3. 4 numbers matched (10 47 52
64) corresponding value for 4 is 10. Add this to the current SUPPORTING
VALUE (11000+30+10). Hence the SUPPORTING VALUE for the first
combination would become 11040 (11000+30+10).

Perform this calculation for all 1002 combinations. Sort the entire
combinations on the SUPPORTING VALUE in descending order.

** We should get a result like this: **
C1,C2,C3,C4,C5,C6,C7,C8,C9,C10 | SUPPORTING VALUE
10,16,28,47,51,52,55,64,71,74 | 2011000
10,16,28,47,51,52,55,64,71,72 | 91010
10,16,28,47,51,52,55,64,72,74 | 91010
10,16,28,47,51,52,55,64,71,75 | 91000
10,16,28,47,51,52,55,64,71,75 | 91000
10,16,28,47,51,52,55,64,71,76 | 91000
10,16,28,47,51,52,55,64,71,77 | 91000
10,16,28,47,51,52,55,64,74,75 | 91000
10,16,28,47,51,52,55,64,74,76 | 91000
10,16,28,47,51,52,55,64,74,77 | 91000
10,16,28,47,51,52,55,71,72,74 | 81010
10,16,28,47,51,52,64,71,72,74 | 81010
10,16,28,47,52,55,64,71,72,74 | 81010
10,16,47,51,52,55,64,71,72,74 | 81010
16,28,47,51,52,55,64,71,72,74 | 81010
10,16,28,47,51,52,55,71,74,75 | 81000

Note: Use the new data that I provided which gives 10413 combinations.
Once this is done, I don't want to keep anything in the array. Just
list it on the worksheet.

Thank you
Maxi

Tom said:
The data always was in an array. I just put it on the worksheet so you
can
see it.
Click to expand...
Click to expand...
 
M

Maxi

Any update on the rest of the code?

Thanks
Maxi
Tom said:
My oversight,
Here is the code to give the 1002, it will probably be a couple days before
I have a chance to look at the rest.

Option Explicit

Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
Dim rng1 As Range, ans As Variant
Dim irw As Long, rw As Range
Dim v1() As Long, i As Long
Dim lMax As Long, cnt As Long
Dim v2a() As Variant, ii As Long
Dim v3a() As Long, j As Long
Dim bDone As Boolean
Dim bPrintout As Boolean

Dim tot As Long, sh As Worksheet
Dim s As String, bAscending As Boolean
Set rng1 = Range("W1:AK19")
ReDim v1(1 To rng1.Rows.Count, 2)
i = 0
For Each rw In rng1.Rows
cnt = Application.Count(rw)
i = i + 1
v1(i, 1) = cnt
v1(i, 2) = Application.Combin(cnt, 10)
tot = tot + v1(i, 2)
Next
ReDim v2a(1 To tot, 1 To 3)
ReDim v3a(1 To tot)
i = 0
irw = 1
For Each rw In rng1.Rows
i = i + 1
cnt = v1(i, 1)
Set rng = rw.Cells.Resize(1, cnt)
v = Application.Transpose(Application _
.Transpose(rng))
n = cnt 'UBound(v, 1)
m = 10
Comb2 n, m, 1, "'", v, v2a, irw

Next


'
bAscending = True
QuickSort v2a, 1, LBound(v2a, 1), UBound(v2a, 1), bAscending

lMax = 1
v2a(1, 2) = 1
For i = 2 To UBound(v2a, 1)
If StrComp(v2a(i, 1), v2a(i - 1, 1), vbBinaryCompare) > 0 Then
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next
v2a(i, 2) = 1
Else
v2a(i, 2) = v2a(i - 1, 2) + 1
End If
If v2a(i, 2) > lMax Then lMax = v2a(i, 2)
Next
i = UBound(v2a) + 1
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next


cnt = 0
If lMax > 2 Then
For i = 1 To tot
If v2a(i, 3) <> lMax And v2a(i, 3) <> lMax - 1 Then
v2a(i, 1) = Empty
Else
If v2a(i, 2) = 1 Then
cnt = cnt + 1
End If
End If
Next
ReDim v3a(1 To cnt, 1 To 10)
cnt = 0

For i = 1 To tot
If Not IsEmpty(v2a(i, 1)) Then
If v2a(i, 2) = 1 Then
cnt = cnt + 1
s = Right(v2a(i, 1), 20)
For j = 1 To 20 Step 2
v3a(cnt, (j + 1) / 2) = CLng(Mid(s, j, 2))
Next j
End If
End If
Next i

' data you want is now in v3a


' change bPrintout to False if you don't want to write a sheet to
' assist in examining the results

bPrintout = True
If bPrintout Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
sh.Range("A1").Resize(tot, 2) = v2a
sh.Range("D1").Resize(cnt, 10).Value = v3a
End If
End If

Erase v2a

End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant, _
v2a() As Variant, irw As Long)
Dim v1 As Variant, i As Long, s1 As String, s2 As String
If m > n - k + 1 Then Exit Sub
If m = 0 Then
v1 = Split(Replace(Trim(s), "'", ""), " ")
s2 = "'"
For i = LBound(v1) To UBound(v1)
s2 = s2 & Format(v(v1(i)), "00")
Next
v2a(irw, 1) = s2
irw = irw + 1
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v, v2a, irw
Comb2 n, m, k + 1, s, v, v2a, irw
End Sub


Sub QuickSort(SortArray, col, L, R, bAscending)
'
'Originally Posted by Jim Rech 10/20/98 Excel.Programming
'Modified to sort on first column of a two dimensional array
'Modified to handle a second dimension greater than 1 (or zero)
'Modified to sort on a specified column in a 2D array
'Modified to do Ascending or Descending
Dim i, j, X, Y, mm

i = L
j = R
X = SortArray((L + R) / 2, col)
If bAscending Then
While (i <= j)
While (SortArray(i, col) < X And i < R)
i = i + 1
Wend
While (X < SortArray(j, col) And j > L)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
Else
While (i <= j)
While (SortArray(i, col) > X And i < R)
i = i + 1
Wend
While (X > SortArray(j, col) And j > L)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
End If
If (L < j) Then Call QuickSort(SortArray, col, L, j, bAscending)
If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)
End Sub

--
Regards,
Tom Ogilvy

Maxi said:
Hi! Tom,

I ran the suppressed version of the code and I got the 4007 x 10
result of the array v3a in the range D1:M4007. Actually I only wanted
1002 combinations (eliminating the duplicates within the frequency 3
and 4). Currently the code is showing (1001 x 4 = 4004 [freq=4]) and
(1 x 3 = 3 [Freq=3] ) which is 4004+3=4007 and I need only 1002.

Moreover, to take the summary of the entire conversation:

In the first step, we created all possible combinations of the 17 rows
present in the range W1:AK19. Answer was 10413 taking into
consideration the new data I provided.

In the second step, we narrowed down those 10413 combinations such that
only combinations with highest frequency and frequency - 1 is left out
in the array. Answer: The total combinations were narrowed down to
1002. (But currently it is showing 4007 that needs to be rectified)

In the LAST step, I want to perform few calculations on these narrowed
down 1002 combinations and list them with a SUPPORTING VALUE. This
SUPPORTING VALUE will be a variable or a new array. This is the final
request from me.

Here is the question for the LAST step:
---------------------------

Following is a table that I want to use for calculating the SUPPORTING
VALUE
4 10
5 30
6 120
7 1000
8 11000
9 80000
10 2000000

Following is the data I have in the range A1:T3
10,12,16,21,22,24,26,27,29,33,47,49,52,54,57,60,61,62,67,72
1,2,5,8,9,10,16,28,30,33,34,39,42,47,51,52,55,64,78,79
3,4,6,10,16,28,31,32,35,40,41,46,47,51,52,55,64,71,74,80

Question:
Pick up first combination from the narrowed down 1002 combinations
(which is 9 10 12 21 22 47 49 52 64 72) and check how many number
matched in the range A1:T1. In this example, 8 numbers matched (10 12
21 22 47 49 52 72). Now look at the table, the corresponding value for
8 is 11000 therefore assign 11000 to the SUPPORTING VALUE. Move to
range A2:T2. 5 numbers matched (9 10 47 52 64). Correspondng value for
5 in the table is 30 now add this to the current SUPPORTING VALUE
(11000+30). Move to the next range A3:T3. 4 numbers matched (10 47 52
64) corresponding value for 4 is 10. Add this to the current SUPPORTING
VALUE (11000+30+10). Hence the SUPPORTING VALUE for the first
combination would become 11040 (11000+30+10).

Perform this calculation for all 1002 combinations. Sort the entire
combinations on the SUPPORTING VALUE in descending order.

** We should get a result like this: **
C1,C2,C3,C4,C5,C6,C7,C8,C9,C10 | SUPPORTING VALUE
10,16,28,47,51,52,55,64,71,74 | 2011000
10,16,28,47,51,52,55,64,71,72 | 91010
10,16,28,47,51,52,55,64,72,74 | 91010
10,16,28,47,51,52,55,64,71,75 | 91000
10,16,28,47,51,52,55,64,71,75 | 91000
10,16,28,47,51,52,55,64,71,76 | 91000
10,16,28,47,51,52,55,64,71,77 | 91000
10,16,28,47,51,52,55,64,74,75 | 91000
10,16,28,47,51,52,55,64,74,76 | 91000
10,16,28,47,51,52,55,64,74,77 | 91000
10,16,28,47,51,52,55,71,72,74 | 81010
10,16,28,47,51,52,64,71,72,74 | 81010
10,16,28,47,52,55,64,71,72,74 | 81010
10,16,47,51,52,55,64,71,72,74 | 81010
16,28,47,51,52,55,64,71,72,74 | 81010
10,16,28,47,51,52,55,71,74,75 | 81000

Note: Use the new data that I provided which gives 10413 combinations.
Once this is done, I don't want to keep anything in the array. Just
list it on the worksheet.

Thank you
Maxi

Tom said:
The data always was in an array. I just put it on the worksheet so you
can
see it.
Click to expand...
Click to expand...
Click to expand...
 
T

Tom Ogilvy

My results vary slightly from what you have posted, but I have verified mine
using formulas, and they appear to be correct.

Option Explicit

Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
Dim rng1 As Range, ans As Variant
Dim irw As Long, rw As Range
Dim v1() As Long, i As Long
Dim lMax As Long, cnt As Long
Dim v2a() As Variant, ii As Long
Dim v3a() As Long, j As Long
Dim v4a As Variant, k As Long
Dim v5a As Variant, l As Long
Dim bDone As Boolean
Dim bPrintout As Boolean
Dim sArr As String, cnt1 As Long
Dim tot As Long, sh As Worksheet
Dim s As String, bAscending As Boolean
Dim sh1 As Worksheet

Set sh1 = ActiveSheet

sArr = "{4,10;5,30;" & _
"6,120;7,1000;" & _
"8,11000;9,80000;" & _
"10,2000000}"
v5a = Evaluate(sArr)



Set rng1 = Range("W1:AK19")
ReDim v1(1 To rng1.Rows.Count, 2)
i = 0
For Each rw In rng1.Rows
cnt = Application.Count(rw)
i = i + 1
v1(i, 1) = cnt
v1(i, 2) = Application.Combin(cnt, 10)
tot = tot + v1(i, 2)
Next
ReDim v2a(1 To tot, 1 To 3)
ReDim v3a(1 To tot)
i = 0
irw = 1
For Each rw In rng1.Rows
i = i + 1
cnt = v1(i, 1)
Set rng = rw.Cells.Resize(1, cnt)
v = Application.Transpose(Application _
.Transpose(rng))
n = cnt 'UBound(v, 1)
m = 10
Comb2 n, m, 1, "'", v, v2a, irw

Next


'
bAscending = True
QuickSort v2a, 1, LBound(v2a, 1), UBound(v2a, 1), bAscending

lMax = 1
v2a(1, 2) = 1
For i = 2 To UBound(v2a, 1)
If StrComp(v2a(i, 1), v2a(i - 1, 1), vbBinaryCompare) > 0 Then
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next
v2a(i, 2) = 1
Else
v2a(i, 2) = v2a(i - 1, 2) + 1
End If
If v2a(i, 2) > lMax Then lMax = v2a(i, 2)
Next
i = UBound(v2a) + 1
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next


cnt = 0
If lMax > 2 Then
For i = 1 To tot
If v2a(i, 3) <> lMax And v2a(i, 3) <> lMax - 1 Then
v2a(i, 1) = Empty
Else
If v2a(i, 2) = 1 Then
cnt = cnt + 1
End If
End If
Next
ReDim v3a(1 To cnt, 1 To 11)
cnt = 0

For i = 1 To tot
If Not IsEmpty(v2a(i, 1)) Then
If v2a(i, 2) = 1 Then
cnt = cnt + 1
s = Right(v2a(i, 1), 20)
For j = 1 To 20 Step 2
v3a(cnt, (j + 1) / 2) = CLng(Mid(s, j, 2))
Next j
End If
End If
Next i

' data you want is now in v3a




v4a = sh1.Range("A1").CurrentRegion

For i = 1 To cnt ' ubound(v3a,1)
v3a(i, 11) = 0
For k = 1 To UBound(v4a, 1)
cnt1 = 0
For j = 1 To 10
For l = LBound(v4a, 2) To UBound(v4a, 2)
If v3a(i, j) = v4a(k, l) Then
cnt1 = cnt1 + 1
Exit For
End If
Next l
Next j
For m = LBound(v5a, 1) To UBound(v5a, 1)
If cnt1 = v5a(m, LBound(v5a, 2)) Then
v3a(i, 11) = v3a(i, 11) + v5a(m, UBound(v5a, 2))
Exit For
End If
Next m
Next k
Next i

bAscending = False
QuickSort v3a, 11, LBound(v3a, 1), UBound(v3a, 1), bAscending

' change bPrintout to False if you don't want to write a sheet to
' assist in examining the results

bPrintout = True
If bPrintout Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
sh.Range("A1").Resize(cnt, 11).Value = v3a
End If
Else
msgbox "Max duplicates is 2, do nothing"
End If ' lMax > 2
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant, _
v2a() As Variant, irw As Long)
Dim v1 As Variant, i As Long, s1 As String, s2 As String
If m > n - k + 1 Then Exit Sub
If m = 0 Then
v1 = Split(Replace(Trim(s), "'", ""), " ")
s2 = "'"
For i = LBound(v1) To UBound(v1)
s2 = s2 & Format(v(v1(i)), "00")
Next
v2a(irw, 1) = s2
irw = irw + 1
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v, v2a, irw
Comb2 n, m, k + 1, s, v, v2a, irw
End Sub


Sub QuickSort(SortArray, col, l, R, bAscending)
'
'Originally Posted by Jim Rech 10/20/98 Excel.Programming
'Modified to sort on first column of a two dimensional array
'Modified to handle a second dimension greater than 1 (or zero)
'Modified to sort on a specified column in a 2D array
'Modified to do Ascending or Descending
Dim i, j, X, Y, mm

i = l
j = R
X = SortArray((l + R) / 2, col)
If bAscending Then
While (i <= j)
While (SortArray(i, col) < X And i < R)
i = i + 1
Wend
While (X < SortArray(j, col) And j > l)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
Else
While (i <= j)
While (SortArray(i, col) > X And i < R)
i = i + 1
Wend
While (X > SortArray(j, col) And j > l)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
End If
If (l < j) Then Call QuickSort(SortArray, col, l, j, bAscending)
If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)
End Sub




--
Regards,
Tom Ogilvy

Maxi said:
Any update on the rest of the code?

Thanks
Maxi
Tom said:
My oversight,
Here is the code to give the 1002, it will probably be a couple days
before
I have a chance to look at the rest.

Option Explicit

Sub Combinations()
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
Dim rng1 As Range, ans As Variant
Dim irw As Long, rw As Range
Dim v1() As Long, i As Long
Dim lMax As Long, cnt As Long
Dim v2a() As Variant, ii As Long
Dim v3a() As Long, j As Long
Dim bDone As Boolean
Dim bPrintout As Boolean

Dim tot As Long, sh As Worksheet
Dim s As String, bAscending As Boolean
Set rng1 = Range("W1:AK19")
ReDim v1(1 To rng1.Rows.Count, 2)
i = 0
For Each rw In rng1.Rows
cnt = Application.Count(rw)
i = i + 1
v1(i, 1) = cnt
v1(i, 2) = Application.Combin(cnt, 10)
tot = tot + v1(i, 2)
Next
ReDim v2a(1 To tot, 1 To 3)
ReDim v3a(1 To tot)
i = 0
irw = 1
For Each rw In rng1.Rows
i = i + 1
cnt = v1(i, 1)
Set rng = rw.Cells.Resize(1, cnt)
v = Application.Transpose(Application _
.Transpose(rng))
n = cnt 'UBound(v, 1)
m = 10
Comb2 n, m, 1, "'", v, v2a, irw

Next


'
bAscending = True
QuickSort v2a, 1, LBound(v2a, 1), UBound(v2a, 1), bAscending

lMax = 1
v2a(1, 2) = 1
For i = 2 To UBound(v2a, 1)
If StrComp(v2a(i, 1), v2a(i - 1, 1), vbBinaryCompare) > 0 Then
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next
v2a(i, 2) = 1
Else
v2a(i, 2) = v2a(i - 1, 2) + 1
End If
If v2a(i, 2) > lMax Then lMax = v2a(i, 2)
Next
i = UBound(v2a) + 1
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next


cnt = 0
If lMax > 2 Then
For i = 1 To tot
If v2a(i, 3) <> lMax And v2a(i, 3) <> lMax - 1 Then
v2a(i, 1) = Empty
Else
If v2a(i, 2) = 1 Then
cnt = cnt + 1
End If
End If
Next
ReDim v3a(1 To cnt, 1 To 10)
cnt = 0

For i = 1 To tot
If Not IsEmpty(v2a(i, 1)) Then
If v2a(i, 2) = 1 Then
cnt = cnt + 1
s = Right(v2a(i, 1), 20)
For j = 1 To 20 Step 2
v3a(cnt, (j + 1) / 2) = CLng(Mid(s, j, 2))
Next j
End If
End If
Next i

' data you want is now in v3a


' change bPrintout to False if you don't want to write a sheet to
' assist in examining the results

bPrintout = True
If bPrintout Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
sh.Range("A1").Resize(tot, 2) = v2a
sh.Range("D1").Resize(cnt, 10).Value = v3a
End If
End If

Erase v2a

End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant, _
v2a() As Variant, irw As Long)
Dim v1 As Variant, i As Long, s1 As String, s2 As String
If m > n - k + 1 Then Exit Sub
If m = 0 Then
v1 = Split(Replace(Trim(s), "'", ""), " ")
s2 = "'"
For i = LBound(v1) To UBound(v1)
s2 = s2 & Format(v(v1(i)), "00")
Next
v2a(irw, 1) = s2
irw = irw + 1
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v, v2a, irw
Comb2 n, m, k + 1, s, v, v2a, irw
End Sub


Sub QuickSort(SortArray, col, L, R, bAscending)
'
'Originally Posted by Jim Rech 10/20/98 Excel.Programming
'Modified to sort on first column of a two dimensional array
'Modified to handle a second dimension greater than 1 (or zero)
'Modified to sort on a specified column in a 2D array
'Modified to do Ascending or Descending
Dim i, j, X, Y, mm

i = L
j = R
X = SortArray((L + R) / 2, col)
If bAscending Then
While (i <= j)
While (SortArray(i, col) < X And i < R)
i = i + 1
Wend
While (X < SortArray(j, col) And j > L)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
Else
While (i <= j)
While (SortArray(i, col) > X And i < R)
i = i + 1
Wend
While (X > SortArray(j, col) And j > L)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
End If
If (L < j) Then Call QuickSort(SortArray, col, L, j, bAscending)
If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)
End Sub

--
Regards,
Tom Ogilvy

Maxi said:
Hi! Tom,

I ran the suppressed version of the code and I got the 4007 x 10
result of the array v3a in the range D1:M4007. Actually I only wanted
1002 combinations (eliminating the duplicates within the frequency 3
and 4). Currently the code is showing (1001 x 4 = 4004 [freq=4]) and
(1 x 3 = 3 [Freq=3] ) which is 4004+3=4007 and I need only 1002.

Moreover, to take the summary of the entire conversation:

In the first step, we created all possible combinations of the 17 rows
present in the range W1:AK19. Answer was 10413 taking into
consideration the new data I provided.

In the second step, we narrowed down those 10413 combinations such that
only combinations with highest frequency and frequency - 1 is left out
in the array. Answer: The total combinations were narrowed down to
1002. (But currently it is showing 4007 that needs to be rectified)

In the LAST step, I want to perform few calculations on these narrowed
down 1002 combinations and list them with a SUPPORTING VALUE. This
SUPPORTING VALUE will be a variable or a new array. This is the final
request from me.

Here is the question for the LAST step:
---------------------------

Following is a table that I want to use for calculating the SUPPORTING
VALUE
4 10
5 30
6 120
7 1000
8 11000
9 80000
10 2000000

Following is the data I have in the range A1:T3
10,12,16,21,22,24,26,27,29,33,47,49,52,54,57,60,61,62,67,72
1,2,5,8,9,10,16,28,30,33,34,39,42,47,51,52,55,64,78,79
3,4,6,10,16,28,31,32,35,40,41,46,47,51,52,55,64,71,74,80

Question:
Pick up first combination from the narrowed down 1002 combinations
(which is 9 10 12 21 22 47 49 52 64 72) and check how many number
matched in the range A1:T1. In this example, 8 numbers matched (10 12
21 22 47 49 52 72). Now look at the table, the corresponding value for
8 is 11000 therefore assign 11000 to the SUPPORTING VALUE. Move to
range A2:T2. 5 numbers matched (9 10 47 52 64). Correspondng value for
5 in the table is 30 now add this to the current SUPPORTING VALUE
(11000+30). Move to the next range A3:T3. 4 numbers matched (10 47 52
64) corresponding value for 4 is 10. Add this to the current SUPPORTING
VALUE (11000+30+10). Hence the SUPPORTING VALUE for the first
combination would become 11040 (11000+30+10).

Perform this calculation for all 1002 combinations. Sort the entire
combinations on the SUPPORTING VALUE in descending order.

** We should get a result like this: **
C1,C2,C3,C4,C5,C6,C7,C8,C9,C10 | SUPPORTING VALUE
10,16,28,47,51,52,55,64,71,74 | 2011000
10,16,28,47,51,52,55,64,71,72 | 91010
10,16,28,47,51,52,55,64,72,74 | 91010
10,16,28,47,51,52,55,64,71,75 | 91000
10,16,28,47,51,52,55,64,71,75 | 91000
10,16,28,47,51,52,55,64,71,76 | 91000
10,16,28,47,51,52,55,64,71,77 | 91000
10,16,28,47,51,52,55,64,74,75 | 91000
10,16,28,47,51,52,55,64,74,76 | 91000
10,16,28,47,51,52,55,64,74,77 | 91000
10,16,28,47,51,52,55,71,72,74 | 81010
10,16,28,47,51,52,64,71,72,74 | 81010
10,16,28,47,52,55,64,71,72,74 | 81010
10,16,47,51,52,55,64,71,72,74 | 81010
16,28,47,51,52,55,64,71,72,74 | 81010
10,16,28,47,51,52,55,71,74,75 | 81000

Note: Use the new data that I provided which gives 10413 combinations.
Once this is done, I don't want to keep anything in the array. Just
list it on the worksheet.

Thank you
Maxi

Tom Ogilvy wrote:
The data always was in an array. I just put it on the worksheet so
you
can
see it.
Click to expand...
Click to expand...
Click to expand...
 
M

Maxi

Thanks Tom,

Possibily the result I posted may be wrong and I see there is only
slight difference. Your result must be the appropriate one.

Few more doubts that I need to clarify:

The new data I provided was creating overall 10413 combinations out of
which 1001 unique combinations were repeated 4x and 1 unique
combination was repeating 1x = 1002 combinations on which you ran the
new SUPPORTING VALUE code to find out supporting value for each
combination.

I have one more requirement where instead of analyzing only 1002
combinations, I want to analyze all 4405 unique combinations (1001 =
4x, 1 = 3x, 3003 = 2x and 400 = 1x). I got these 4405 combinations
which are unique from the total 10413 combinations after eliminating
all duplicates. After doing this, run the SUPPORTING VALUE routine on
these 4405 combinations.

This is what I tried:
Instead of : If v2a(i, 3) <> lMax And v2a(i, 3) <> lMax - 1 Then
I tried : If v2a(i, 3) < 1 Then

Is this correct? Or will it require few other changes?

Also 4405 can easily fit into a worksheet but on a real data if the
worksheet overflows, I want to list only the top 65536 combinations
sorted on SUPPORTING VALUE descending.

Thanks
Maxi
 
T

Tom Ogilvy

For i = 1 To tot
If v2a(i, 3) <> lMax And v2a(i, 3) <> lMax - 1 Then
v2a(i, 1) = Empty
Else
If v2a(i, 2) = 1 Then
cnt = cnt + 1
End If
End If
Next
ReDim v3a(1 To cnt, 1 To 11)
cnt = 0

becomes

For i = 1 To tot
If v2a(i, 2) = 1 Then
cnt = cnt + 1
End If
Next
ReDim v3a(1 To cnt, 1 To 11)
cnt = 0


now change
If bPrintout Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
sh.Range("A1").Resize(cnt, 11).Value = v3a
End If


to printout as you wish.
 
M

Maxi

The line sh.Range("A1").Resize(cnt, 11).Value = v3a will put the result
on the worksheet.
Here cnt value is 4405 and it will resize the range to A1:K4405 and
will put the result.

But if cnt value goes above 65536 then what would be the syntax to list
only top 65536 and erase all other contents of array v3a?

something like
If cnt<=65536 then
sh.Range("A1").Resize(65536, 11).Value = v3a(65536,11)
Else
msgbox "Too may combinations, listing only top 65536"
Endif

I am not sure if the syntax is correct.

---------------------------------------------------------------------------------------------------

One more question

The data that I provided in W1:AK19 is a result of another macro. Now
that macro is taking lot of physical memory and virual memory and slows
down the processing speed and now I have to change that macro so that
it converts the numbers in comma seperated 1D array and keeps the value
in the array itself instead of listing them on a worksheet. Like this:

Sub foo()

Dim SData(1 To 19)
SData(1) = "4,9,10,21,35,47,64,72,74,75"
SData(2) = "4,9,10,21,33,41,47,57,60,72,74"
SData(3) = "3,4,10,11,21,32,33,35,60,69,74"
SData(4) = "3,4,7,10,21,33,37,47,57,69,75"
SData(5) = "3,7,10,11,35,47,57,60,64,66,67,72,73,79,80"
SData(6) = "3,7,10,11,35,47,57,60,64,66,67,72,73,79,80"
SData(7) = "4,7,9,10,11,32,35,41,69,74"
SData(8) = "3,4,10,21,32,37,47,64,69,72,75,77"
SData(9) = "3,7,11,33,35,37,41,47,64,75"
SData(10) = "4,6,9,10,15,21,31,47,72,74"
SData(11) = "6,9,13,21,22,31,49,52,63,64,75"
SData(12) = "9,10,12,21,22,47,49,52,64,72"
SData(13) = "9,10,12,21,22,47,49,52,64,72"
SData(14) = "9,10,12,21,22,47,49,52,64,72"
SData(15) = "6,9,10,13,21,49,52,63,72,74,75,79,80"
SData(16) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(17) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(18) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(19) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"

Combinations SData

End Sub

I need a parameter one in your combinations() routine which will read
data from the array SData instead of reading it from the W1:AK19 range
like it was doing earlier.

Thanks
Maxi
 
T

Tom Ogilvy

If bPrintout Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
if Ubound(v3a,1) <= rows.count then
sh.Range("A1").Resize(cnt, 11).Value = v3a
else
dim v6a(1 to 65536, 1 to 11) as Long
for i = 1 to 65536
for j = 1 to 11
v6a(i,j) = v3a(i,j)
next i
next j
sh.Range("A1").Resize(65536,11).Value = v6a
end if
End If

I will look at you new request later.
 
M

Maxi

Thank you.

For the other request, I think we need two parameters:
1. The actual array with comma seperated strings of numbers
2. The number of items in that string array

I have both ready and I need to call your code through my code like
this:

Combinations SData,Sitems

where SData is the array and Sitems will have the count 19

Thanks
Maxi
 
T

Tom Ogilvy

Option Explicit
Sub foo()
Dim sItems
Dim SData(1 To 19)
SData(1) = "4,9,10,21,35,47,64,72,74,75"
SData(2) = "4,9,10,21,33,41,47,57,60,72,74"
SData(3) = "3,4,10,11,21,32,33,35,60,69,74"
SData(4) = "3,4,7,10,21,33,37,47,57,69,75"
SData(5) = "3,7,10,11,35,47,57,60,64,66,67,72,73,79,80"
SData(6) = "3,7,10,11,35,47,57,60,64,66,67,72,73,79,80"
SData(7) = "4,7,9,10,11,32,35,41,69,74"
SData(8) = "3,4,10,21,32,37,47,64,69,72,75,77"
SData(9) = "3,7,11,33,35,37,41,47,64,75"
SData(10) = "4,6,9,10,15,21,31,47,72,74"
SData(11) = "6,9,13,21,22,31,49,52,63,64,75"
SData(12) = "9,10,12,21,22,47,49,52,64,72"
SData(13) = "9,10,12,21,22,47,49,52,64,72"
SData(14) = "9,10,12,21,22,47,49,52,64,72"
SData(15) = "6,9,10,13,21,49,52,63,72,74,75,79,80"
SData(16) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(17) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(18) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(19) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
sItems = 19

Combinations SData, sItems

End Sub


Sub Combinations(SData, sItems)
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
Dim rng1 As Range, ans As Variant
Dim irw As Long, rw As Range
Dim v1() As Long, i As Long
Dim lMax As Long, cnt As Long
Dim v2a() As Variant, ii As Long
Dim v3a() As Long, j As Long
Dim v4a As Variant, k As Long
Dim v5a As Variant, l As Long
Dim v6a() As Long
Dim bDone As Boolean, kk As Long
Dim sStr As String, sChr As String
Dim bPrintout As Boolean
Dim sArr As String, cnt1 As Long
Dim tot As Long, sh As Worksheet
Dim s As String, bAscending As Boolean
Dim sh1 As Worksheet

Set sh1 = ActiveSheet

sArr = "{4,10;5,30;" & _
"6,120;7,1000;" & _
"8,11000;9,80000;" & _
"10,2000000}"
v5a = Evaluate(sArr)



Set rng1 = Range("W1:AK19")
ReDim v1(1 To sItems, 2)
i = 0
For j = LBound(SData, 1) To LBound(SData, 1) + sItems - 1
cnt = (Len(SData(j)) - Len(Replace(SData(j), ",", ""))) + 1
i = i + 1
v1(i, 1) = cnt
v1(i, 2) = Application.Combin(cnt, 10)
tot = tot + v1(i, 2)
Next j
ReDim v2a(1 To tot, 1 To 3)
ReDim v3a(1 To tot)
i = 0
irw = 1
For j = LBound(SData, 1) To LBound(SData, 1) + sItems - 1
i = i + 1
cnt = v1(i, 1)
' Set rng = rw.Cells.Resize(1, cnt)
ReDim v(1 To cnt)
kk = 1
sStr = ""
For k = 1 To Len(SData(j))
sChr = Mid(SData(j), k, 1)
If sChr = "," Then
v(kk) = CLng(sStr)
sStr = ""
kk = kk + 1
Else
sStr = sStr & sChr
End If
Next k
If sStr <> "" Then
v(kk) = sStr
End If
n = cnt 'UBound(v, 1)
m = 10
Comb2 n, m, 1, "'", v, v2a, irw

Next j


'
bAscending = True
QuickSort v2a, 1, LBound(v2a, 1), UBound(v2a, 1), bAscending

lMax = 1
v2a(1, 2) = 1
For i = 2 To UBound(v2a, 1)
If StrComp(v2a(i, 1), v2a(i - 1, 1), vbBinaryCompare) > 0 Then
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next
v2a(i, 2) = 1
Else
v2a(i, 2) = v2a(i - 1, 2) + 1
End If
If v2a(i, 2) > lMax Then lMax = v2a(i, 2)
Next
i = UBound(v2a) + 1
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next

cnt = 0

If lMax > 2 Then
For i = 1 To tot
If v2a(i, 2) = 1 Then
cnt = cnt + 1
End If
Next
ReDim v3a(1 To cnt, 1 To 11)
cnt = 0


For i = 1 To tot
If Not IsEmpty(v2a(i, 1)) Then
If v2a(i, 2) = 1 Then
cnt = cnt + 1
s = Right(v2a(i, 1), 20)
For j = 1 To 20 Step 2
v3a(cnt, (j + 1) / 2) = CLng(Mid(s, j, 2))
Next j
End If
End If
Next i

' data you want is now in v3a




v4a = sh1.Range("A1").CurrentRegion

For i = 1 To cnt ' ubound(v3a,1)
v3a(i, 11) = 0
For k = 1 To UBound(v4a, 1)
cnt1 = 0
For j = 1 To 10
For l = LBound(v4a, 2) To UBound(v4a, 2)
If v3a(i, j) = v4a(k, l) Then
cnt1 = cnt1 + 1
Exit For
End If
Next l
Next j
For m = LBound(v5a, 1) To UBound(v5a, 1)
If cnt1 = v5a(m, LBound(v5a, 2)) Then
v3a(i, 11) = v3a(i, 11) + v5a(m, UBound(v5a, 2))
Exit For
End If
Next m
Next k
Next i

bAscending = False
QuickSort v3a, 11, LBound(v3a, 1), UBound(v3a, 1), bAscending

' change bPrintout to False if you don't want to write a sheet to
' assist in examining the results

bPrintout = True
If bPrintout Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
If UBound(v3a, 1) <= Rows.Count Then
sh.Range("A1").Resize(cnt, 11).Value = v3a
Else
ReDim v6a(1 To 65536, 1 To 11)
For i = 1 To 65536
For j = 1 To 11
v6a(i, j) = v3a(i, j)
Next j
Next i
sh.Range("A1").Resize(65536, 11).Value = v6a
End If
End If

Else
MsgBox "Max duplicates is 2, do nothing"
End If ' lMax > 2
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant, _
v2a() As Variant, irw As Long)
Dim v1 As Variant, i As Long, s1 As String, s2 As String
If m > n - k + 1 Then Exit Sub
If m = 0 Then
v1 = Split(Replace(Trim(s), "'", ""), " ")
s2 = "'"
For i = LBound(v1) To UBound(v1)
s2 = s2 & Format(v(v1(i)), "00")
Next
v2a(irw, 1) = s2
irw = irw + 1
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v, v2a, irw
Comb2 n, m, k + 1, s, v, v2a, irw
End Sub


Sub QuickSort(SortArray, col, l, R, bAscending)
'
'Originally Posted by Jim Rech 10/20/98 Excel.Programming
'Modified to sort on first column of a two dimensional array
'Modified to handle a second dimension greater than 1 (or zero)
'Modified to sort on a specified column in a 2D array
'Modified to do Ascending or Descending
Dim i, j, X, Y, mm

i = l
j = R
X = SortArray((l + R) / 2, col)
If bAscending Then
While (i <= j)
While (SortArray(i, col) < X And i < R)
i = i + 1
Wend
While (X < SortArray(j, col) And j > l)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
Else
While (i <= j)
While (SortArray(i, col) > X And i < R)
i = i + 1
Wend
While (X > SortArray(j, col) And j > l)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
End If
If (l < j) Then Call QuickSort(SortArray, col, l, j, bAscending)
If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)
End Sub

--
Regards,
Tom Ogilvy

Maxi said:
Thank you.

For the other request, I think we need two parameters:
1. The actual array with comma seperated strings of numbers
2. The number of items in that string array

I have both ready and I need to call your code through my code like
this:

Combinations SData,Sitems

where SData is the array and Sitems will have the count 19

Thanks
Maxi
Click to expand...
 
M

Maxi

Thank you very much for your help. Greatly appreciated. Absolutely
fantastic !!!

I am not among those who ask for help only to get the work done. I
always believed in continuous learning and I have learnt a lot through
your replies.

Do you have your personal webpage / website or a personal profile
listed on any of the public forums? Just wanted to know more about you.

For now I have one more question: Keeping the logic same, if I want to
create combinations of 6 numbers instead of 10 numbers then would it be
okay if I change the following lines? or is there anything else that
needs to be changed more?

Change the following 10 lines

FROM:

v1(i, 2) = Application.Combin(cnt, 10)
m = 10
For j = 1 To 10
s = Right(v2a(i, 1), 20)
For j = 1 To 20 Step 2
ReDim v3a(1 To cnt, 1 To 11)
v3a(i, 11) = 0
v3a(i, 11) = v3a(i, 11) + v5a(m, UBound(v5a, 2))
QuickSort v3a, 11, LBound(v3a, 1), UBound(v3a, 1), bAscending
sh.Range("A1").Resize(cnt, 11).Value = v3a

TO:

v1(i, 2) = Application.Combin(cnt, 6)
m = 6
For j = 1 To 6
s = Right(v2a(i, 1), 12)
For j = 1 To 12 Step 2
ReDim v3a(1 To cnt, 1 To 7)
v3a(i, 7) = 0
v3a(i, 7) = v3a(i, 7) + v5a(m, UBound(v5a, 2))
QuickSort v3a, 7, LBound(v3a, 1), UBound(v3a, 1), bAscending
sh.Range("A1").Resize(cnt, 7).Value = v3a

PS: I have posted another question. If you have time, please have a
look at the below link.
http://groups.google.com/group/micr...read/thread/d1a3a1f74536d0f8/7ccc781681fafa5b
Subject: Advanced - Search and Update

Thanks
Maxi

Tom said:
Option Explicit
Sub foo()
Dim sItems
Dim SData(1 To 19)
SData(1) = "4,9,10,21,35,47,64,72,74,75"
SData(2) = "4,9,10,21,33,41,47,57,60,72,74"
SData(3) = "3,4,10,11,21,32,33,35,60,69,74"
SData(4) = "3,4,7,10,21,33,37,47,57,69,75"
SData(5) = "3,7,10,11,35,47,57,60,64,66,67,72,73,79,80"
SData(6) = "3,7,10,11,35,47,57,60,64,66,67,72,73,79,80"
SData(7) = "4,7,9,10,11,32,35,41,69,74"
SData(8) = "3,4,10,21,32,37,47,64,69,72,75,77"
SData(9) = "3,7,11,33,35,37,41,47,64,75"
SData(10) = "4,6,9,10,15,21,31,47,72,74"
SData(11) = "6,9,13,21,22,31,49,52,63,64,75"
SData(12) = "9,10,12,21,22,47,49,52,64,72"
SData(13) = "9,10,12,21,22,47,49,52,64,72"
SData(14) = "9,10,12,21,22,47,49,52,64,72"
SData(15) = "6,9,10,13,21,49,52,63,72,74,75,79,80"
SData(16) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(17) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(18) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(19) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
sItems = 19

Combinations SData, sItems

End Sub


Sub Combinations(SData, sItems)
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
Dim rng1 As Range, ans As Variant
Dim irw As Long, rw As Range
Dim v1() As Long, i As Long
Dim lMax As Long, cnt As Long
Dim v2a() As Variant, ii As Long
Dim v3a() As Long, j As Long
Dim v4a As Variant, k As Long
Dim v5a As Variant, l As Long
Dim v6a() As Long
Dim bDone As Boolean, kk As Long
Dim sStr As String, sChr As String
Dim bPrintout As Boolean
Dim sArr As String, cnt1 As Long
Dim tot As Long, sh As Worksheet
Dim s As String, bAscending As Boolean
Dim sh1 As Worksheet

Set sh1 = ActiveSheet

sArr = "{4,10;5,30;" & _
"6,120;7,1000;" & _
"8,11000;9,80000;" & _
"10,2000000}"
v5a = Evaluate(sArr)



Set rng1 = Range("W1:AK19")
ReDim v1(1 To sItems, 2)
i = 0
For j = LBound(SData, 1) To LBound(SData, 1) + sItems - 1
cnt = (Len(SData(j)) - Len(Replace(SData(j), ",", ""))) + 1
i = i + 1
v1(i, 1) = cnt
v1(i, 2) = Application.Combin(cnt, 10)
tot = tot + v1(i, 2)
Next j
ReDim v2a(1 To tot, 1 To 3)
ReDim v3a(1 To tot)
i = 0
irw = 1
For j = LBound(SData, 1) To LBound(SData, 1) + sItems - 1
i = i + 1
cnt = v1(i, 1)
' Set rng = rw.Cells.Resize(1, cnt)
ReDim v(1 To cnt)
kk = 1
sStr = ""
For k = 1 To Len(SData(j))
sChr = Mid(SData(j), k, 1)
If sChr = "," Then
v(kk) = CLng(sStr)
sStr = ""
kk = kk + 1
Else
sStr = sStr & sChr
End If
Next k
If sStr <> "" Then
v(kk) = sStr
End If
n = cnt 'UBound(v, 1)
m = 10
Comb2 n, m, 1, "'", v, v2a, irw

Next j


'
bAscending = True
QuickSort v2a, 1, LBound(v2a, 1), UBound(v2a, 1), bAscending

lMax = 1
v2a(1, 2) = 1
For i = 2 To UBound(v2a, 1)
If StrComp(v2a(i, 1), v2a(i - 1, 1), vbBinaryCompare) > 0 Then
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next
v2a(i, 2) = 1
Else
v2a(i, 2) = v2a(i - 1, 2) + 1
End If
If v2a(i, 2) > lMax Then lMax = v2a(i, 2)
Next
i = UBound(v2a) + 1
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next

cnt = 0

If lMax > 2 Then
For i = 1 To tot
If v2a(i, 2) = 1 Then
cnt = cnt + 1
End If
Next
ReDim v3a(1 To cnt, 1 To 11)
cnt = 0


For i = 1 To tot
If Not IsEmpty(v2a(i, 1)) Then
If v2a(i, 2) = 1 Then
cnt = cnt + 1
s = Right(v2a(i, 1), 20)
For j = 1 To 20 Step 2
v3a(cnt, (j + 1) / 2) = CLng(Mid(s, j, 2))
Next j
End If
End If
Next i

' data you want is now in v3a




v4a = sh1.Range("A1").CurrentRegion

For i = 1 To cnt ' ubound(v3a,1)
v3a(i, 11) = 0
For k = 1 To UBound(v4a, 1)
cnt1 = 0
For j = 1 To 10
For l = LBound(v4a, 2) To UBound(v4a, 2)
If v3a(i, j) = v4a(k, l) Then
cnt1 = cnt1 + 1
Exit For
End If
Next l
Next j
For m = LBound(v5a, 1) To UBound(v5a, 1)
If cnt1 = v5a(m, LBound(v5a, 2)) Then
v3a(i, 11) = v3a(i, 11) + v5a(m, UBound(v5a, 2))
Exit For
End If
Next m
Next k
Next i

bAscending = False
QuickSort v3a, 11, LBound(v3a, 1), UBound(v3a, 1), bAscending

' change bPrintout to False if you don't want to write a sheet to
' assist in examining the results

bPrintout = True
If bPrintout Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
If UBound(v3a, 1) <= Rows.Count Then
sh.Range("A1").Resize(cnt, 11).Value = v3a
Else
ReDim v6a(1 To 65536, 1 To 11)
For i = 1 To 65536
For j = 1 To 11
v6a(i, j) = v3a(i, j)
Next j
Next i
sh.Range("A1").Resize(65536, 11).Value = v6a
End If
End If

Else
MsgBox "Max duplicates is 2, do nothing"
End If ' lMax > 2
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant, _
v2a() As Variant, irw As Long)
Dim v1 As Variant, i As Long, s1 As String, s2 As String
If m > n - k + 1 Then Exit Sub
If m = 0 Then
v1 = Split(Replace(Trim(s), "'", ""), " ")
s2 = "'"
For i = LBound(v1) To UBound(v1)
s2 = s2 & Format(v(v1(i)), "00")
Next
v2a(irw, 1) = s2
irw = irw + 1
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v, v2a, irw
Comb2 n, m, k + 1, s, v, v2a, irw
End Sub


Sub QuickSort(SortArray, col, l, R, bAscending)
'
'Originally Posted by Jim Rech 10/20/98 Excel.Programming
'Modified to sort on first column of a two dimensional array
'Modified to handle a second dimension greater than 1 (or zero)
'Modified to sort on a specified column in a 2D array
'Modified to do Ascending or Descending
Dim i, j, X, Y, mm

i = l
j = R
X = SortArray((l + R) / 2, col)
If bAscending Then
While (i <= j)
While (SortArray(i, col) < X And i < R)
i = i + 1
Wend
While (X < SortArray(j, col) And j > l)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
Else
While (i <= j)
While (SortArray(i, col) > X And i < R)
i = i + 1
Wend
While (X > SortArray(j, col) And j > l)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
End If
If (l < j) Then Call QuickSort(SortArray, col, l, j, bAscending)
If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)
End Sub
Click to expand...
 
T

Tom Ogilvy

I have modified the code so you can specify the size of the combination.

In the routine Combinations, change the line
iComb = 6 to indicate the size of the combination. (set for 6 as
requested)

Option Explicit
Sub foo()
Dim sItems
Dim SData(1 To 19)
SData(1) = "4,9,10,21,35,47,64,72,74,75"
SData(2) = "4,9,10,21,33,41,47,57,60,72,74"
SData(3) = "3,4,10,11,21,32,33,35,60,69,74"
SData(4) = "3,4,7,10,21,33,37,47,57,69,75"
SData(5) = "3,7,10,11,35,47,57,60,64,66,67,72,73,79,80"
SData(6) = "3,7,10,11,35,47,57,60,64,66,67,72,73,79,80"
SData(7) = "4,7,9,10,11,32,35,41,69,74"
SData(8) = "3,4,10,21,32,37,47,64,69,72,75,77"
SData(9) = "3,7,11,33,35,37,41,47,64,75"
SData(10) = "4,6,9,10,15,21,31,47,72,74"
SData(11) = "6,9,13,21,22,31,49,52,63,64,75"
SData(12) = "9,10,12,21,22,47,49,52,64,72"
SData(13) = "9,10,12,21,22,47,49,52,64,72"
SData(14) = "9,10,12,21,22,47,49,52,64,72"
SData(15) = "6,9,10,13,21,49,52,63,72,74,75,79,80"
SData(16) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(17) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(18) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
SData(19) = "10,16,28,47,51,52,55,64,71,72,74,75,76,77"
sItems = 19

Combinations SData, sItems

End Sub


Sub Combinations(SData, sItems)
Dim n As Integer, m As Integer
Dim v As Variant, rng As Range
Dim rng1 As Range, ans As Variant
Dim irw As Long, rw As Range
Dim v1() As Long, i As Long
Dim lMax As Long, cnt As Long
Dim v2a() As Variant, ii As Long
Dim v3a() As Long, j As Long
Dim v4a As Variant, k As Long
Dim v5a As Variant, l As Long
Dim v6a() As Long
Dim bDone As Boolean, kk As Long
Dim sStr As String, sChr As String
Dim bPrintout As Boolean
Dim sArr As String, cnt1 As Long
Dim tot As Long, sh As Worksheet
Dim s As String, bAscending As Boolean
Dim sh1 As Worksheet
Dim iComb As Long

Set sh1 = ActiveSheet

sArr = "{4,10;5,30;" & _
"6,120;7,1000;" & _
"8,11000;9,80000;" & _
"10,2000000}"
v5a = Evaluate(sArr)

'
' set size of the combinations here
'
iComb = 6

' Set rng1 = Range("W1:AK19")
ReDim v1(1 To sItems, 2)
i = 0
For j = LBound(SData, 1) To LBound(SData, 1) + sItems - 1
cnt = (Len(SData(j)) - Len(Replace(SData(j), ",", ""))) + 1
i = i + 1
v1(i, 1) = cnt
v1(i, 2) = Application.Combin(cnt, iComb)
tot = tot + v1(i, 2)
Next j
ReDim v2a(1 To tot, 1 To 3)
ReDim v3a(1 To tot)
i = 0
irw = 1
For j = LBound(SData, 1) To LBound(SData, 1) + sItems - 1
i = i + 1
cnt = v1(i, 1)
' Set rng = rw.Cells.Resize(1, cnt)
ReDim v(1 To cnt)
kk = 1
sStr = ""
For k = 1 To Len(SData(j))
sChr = Mid(SData(j), k, 1)
If sChr = "," Then
v(kk) = CLng(sStr)
sStr = ""
kk = kk + 1
Else
sStr = sStr & sChr
End If
Next k
If sStr <> "" Then
v(kk) = sStr
End If
n = cnt 'UBound(v, 1)
'm = 10
m = iComb
Comb2 n, m, 1, "'", v, v2a, irw

Next j


'
bAscending = True
QuickSort v2a, 1, LBound(v2a, 1), UBound(v2a, 1), bAscending

lMax = 1
v2a(1, 2) = 1
For i = 2 To UBound(v2a, 1)
If StrComp(v2a(i, 1), v2a(i - 1, 1), vbBinaryCompare) > 0 Then
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next
v2a(i, 2) = 1
Else
v2a(i, 2) = v2a(i - 1, 2) + 1
End If
If v2a(i, 2) > lMax Then lMax = v2a(i, 2)
Next
i = UBound(v2a) + 1
ii = v2a(i - 1, 2)
For j = i - ii To i - 1
v2a(j, 3) = ii
Next

cnt = 0

If lMax > 2 Then
For i = 1 To tot
If v2a(i, 2) = 1 Then
cnt = cnt + 1
End If
Next
ReDim v3a(1 To cnt, 1 To iComb + 1)
cnt = 0


For i = 1 To tot
If Not IsEmpty(v2a(i, 1)) Then
If v2a(i, 2) = 1 Then
cnt = cnt + 1
s = Right(v2a(i, 1), 2 * iComb)
For j = 1 To 2 * iComb Step 2
v3a(cnt, (j + 1) / 2) = CLng(Mid(s, j, 2))
Next j
End If
End If
Next i

' data you want is now in v3a




v4a = sh1.Range("A1").CurrentRegion

For i = 1 To cnt ' ubound(v3a,1)
v3a(i, iComb + 1) = 0
For k = 1 To UBound(v4a, 1)
cnt1 = 0
For j = 1 To iComb
For l = LBound(v4a, 2) To UBound(v4a, 2)
If v3a(i, j) = v4a(k, l) Then
cnt1 = cnt1 + 1
Exit For
End If
Next l
Next j
For m = LBound(v5a, 1) To UBound(v5a, 1)
If cnt1 = v5a(m, LBound(v5a, 2)) Then
v3a(i, iComb + 1) = v3a(i, iComb + 1) + v5a(m, UBound(v5a, 2))
Exit For
End If
Next m
Next k
Next i

bAscending = False
QuickSort v3a, iComb + 1, LBound(v3a, 1), UBound(v3a, 1), bAscending

' change bPrintout to False if you don't want to write a sheet to
' assist in examining the results

bPrintout = True
If bPrintout Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
If UBound(v3a, 1) <= Rows.Count Then
sh.Range("A1").Resize(cnt, iComb + 1).Value = v3a
Else
ReDim v6a(1 To 65536, 1 To iComb + 1)
For i = 1 To 65536
For j = 1 To iComb + 1
v6a(i, j) = v3a(i, j)
Next j
Next i
sh.Range("A1").Resize(65536, iComb + 1).Value = v6a
End If
End If

Else
MsgBox "Max duplicates is 2, do nothing"
End If ' lMax > 2
End Sub

'Generate combinations of integers k..n taken m at a time, recursively
Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant, _
v2a() As Variant, irw As Long)
Dim v1 As Variant, i As Long, s1 As String, s2 As String
If m > n - k + 1 Then Exit Sub
If m = 0 Then
v1 = Split(Replace(Trim(s), "'", ""), " ")
s2 = "'"
For i = LBound(v1) To UBound(v1)
s2 = s2 & Format(v(v1(i)), "00")
Next
v2a(irw, 1) = s2
irw = irw + 1
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v, v2a, irw
Comb2 n, m, k + 1, s, v, v2a, irw
End Sub


Sub QuickSort(SortArray, col, l, R, bAscending)
'
'Originally Posted by Jim Rech 10/20/98 Excel.Programming
'Modified to sort on first column of a two dimensional array
'Modified to handle a second dimension greater than 1 (or zero)
'Modified to sort on a specified column in a 2D array
'Modified to do Ascending or Descending
Dim i, j, X, Y, mm

i = l
j = R
X = SortArray((l + R) / 2, col)
If bAscending Then
While (i <= j)
While (SortArray(i, col) < X And i < R)
i = i + 1
Wend
While (X < SortArray(j, col) And j > l)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
Else
While (i <= j)
While (SortArray(i, col) > X And i < R)
i = i + 1
Wend
While (X > SortArray(j, col) And j > l)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
End If
If (l < j) Then Call QuickSort(SortArray, col, l, j, bAscending)
If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)
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

Recursive Code 3
Tom Ogilvy code 2
Median of all combinations 1
Combination and Repetition Not Allowed 0
Adding matrices 0
Macro not running anymore 3
median of combinations from values in a column 6
Adjusting alogarithm 18

Top