Tom Ogilvy - Need a little change
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" wrote in message
oups.com...
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,7 8,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.
|