Ignore that one. It writes out some information you don't need. I have
commented out those lines in this version:
Dim arr(0 To 19) As Long
Dim arr1(1 To 6) As Long
Dim arr2(0 To 19) As Long
Dim col(1 To 4) As Long
Dim cnt As Long, ii As Long
Dim j As Long, i As Long, k As Long
Dim m As Long, cell As Range, colm As Range
'Dim sStr as String
i = -1
For Each colm In Range("A1:D5").Columns
For Each cell In colm.Cells
i = i + 1
arr2(i) = cell.Value
Next
Next
j = 7
For i = 1 To 2 ^ 20 - 1
bldArr i, arr, cnt
If cnt = 6 Then
For ii = 1 To 4
col(ii) = 0
arr1(ii) = Empty
Next
arr1(5) = Empty
arr1(6) = Empty
m = 1
' sStr = ""
For k = 0 To 19
' sStr = sStr & arr(k)
If arr(k) = 1 Then
arr1(m) = arr2(k)
m = m + 1
bWrite = False
Select Case k
Case 0, 1, 2, 3, 4
col(1) = col(1) + 1
If col(1) 2 Then Exit For
Case 5, 6, 7, 8, 9
col(2) = col(2) + 1
If col(2) 2 Then Exit For
Case 10, 11, 12, 13, 14
col(3) = col(3) + 1
If col(3) 2 Then Exit For
Case 15, 16, 17, 18, 19
col(4) = col(4) + 1
If col(4) 2 Then Exit For
End Select
bWrite = True
End If
Next
' Debug.Print i, sStr, m
For ii = 1 To 4
If col(ii) = 0 Then
bWrite = False
Exit For
End If
Next
If bWrite Then
Cells(j, 1).Resize(1, 6).Value = arr1
' Cells(j, 7) = i
' Cells(j, 8).Resize(1, 20) = arr
j = j + 1
End If
End If
Next
End Sub
Sub bldArr(num As Long, arr() As Long, cnt As Long)
Dim lNum As Long, i As Long
lNum = num
' Dim sStr As String
' sStr = ""
cnt = 0
For i = 19 To 0 Step -1
If lNum And 2 ^ i Then
cnt = cnt + 1
arr(19 - i) = 1
' sStr = sStr & "1"
If cnt 6 Then Exit Sub
Else
arr(19 - i) = 0
' sStr = sStr & "0"
End If
Next
' If cnt = 2 Then
' Debug.Print num, sStr
' End If
End Sub
--
Regards,
Tom Ogilvy
Tom Ogilvy wrote in message
...
Option Explicit
Sub tester9()
Dim bWrite As Boolean
Dim arr(0 To 19) As Long
Dim arr1(1 To 6) As Long
Dim arr2(0 To 19) As Long
Dim col(1 To 4) As Long
Dim cnt As Long, ii As Long
Dim j As Long, i As Long, k As Long
Dim m As Long, cell As Range, colm As Range
'Dim sStr as String
i = -1
For Each colm In Range("A1:D5").Columns
For Each cell In colm.Cells
i = i + 1
arr2(i) = cell.Value
Next
Next
j = 7
For i = 1 To 2 ^ 20 - 1
bldArr i, arr, cnt
If cnt = 6 Then
For ii = 1 To 4
col(ii) = 0
arr1(ii) = Empty
Next
arr1(5) = Empty
arr1(6) = Empty
m = 1
' sStr = ""
For k = 0 To 19
' sStr = sStr & arr(k)
If arr(k) = 1 Then
arr1(m) = arr2(k)
m = m + 1
bWrite = False
Select Case k
Case 0, 1, 2, 3, 4
col(1) = col(1) + 1
If col(1) 2 Then Exit For
Case 5, 6, 7, 8, 9
col(2) = col(2) + 1
If col(2) 2 Then Exit For
Case 10, 11, 12, 13, 14
col(3) = col(3) + 1
If col(3) 2 Then Exit For
Case 15, 16, 17, 18, 19
col(4) = col(4) + 1
If col(4) 2 Then Exit For
End Select
bWrite = True
End If
Next
' Debug.Print i, sStr, m
For ii = 1 To 4
If col(ii) = 0 Then
bWrite = False
Exit For
End If
Next
If bWrite Then
Cells(j, 1).Resize(1, 6).Value = arr1
Cells(j, 7) = i
Cells(j, 8).Resize(1, 20) = arr
j = j + 1
End If
End If
Next
End Sub
Sub bldArr(num As Long, arr() As Long, cnt As Long)
Dim lNum As Long, i As Long
lNum = num
' Dim sStr As String
' sStr = ""
cnt = 0
For i = 19 To 0 Step -1
If lNum And 2 ^ i Then
cnt = cnt + 1
arr(19 - i) = 1
' sStr = sStr & "1"
If cnt 6 Then Exit Sub
Else
arr(19 - i) = 0
' sStr = sStr & "0"
End If
Next
' If cnt = 2 Then
' Debug.Print num, sStr
' End If
End Sub
--
Regards,
Tom Ogilvy
Michael168 wrote in message
...
Hello Mr.Tom Ogilvy
Thanks for your comments.
Below is what I want.
Col A (1-5) contains 1,2,3,4,5
Col B (1-5) contains 6,7,8,9,10
Col C (1-5) contains 11,12,13,14,15
Col D (1-5) contains 16,17,18,19,20
What I want is from col A-D I want to generate groups of numbers
consisting of 6 unique nos under the conditions that each group of nos
must contains max of 2 nos from either two of the columns and 1 no each
from the other 2 columns. I hope you can get what I mean.
e.g. 1st group= 1,2,6,7,11,16
2nd group= 1,2,6,11,12,17
3rd group=2,6,7,13,17,18
and so on.... until the combination complete with the above conditions
of forming the groups of nos.
What I mean unique is that each group of 6 nos does not repeated
itself.
Thank you
------------------------------------------------
~~ Message posted from http://www.ExcelTip.com/
~~ View and post usenet messages directly from
http://www.ExcelForum.com/