Formula or Code Needed

  • Thread starter Thread starter Michael168
  • Start date Start date
M

Michael168

Is there anyone can help me to code the module?

I have 4 columns of data (A:D) . Each column contains 5 rows (1-5).Each
column contain 1 unique nos.
This is for generating Jackpot combinations, i.e. 6 numbers in a
group.
The condition is that the group generated must contain two pair numbers
from column A:D and two single numbers from column A:D.
In another word the maximum numbers can get from each column is 2
numbers and the minimun number is 1 number.
The combinations must come from 4 columns.
 
this is the third time you posted this. If you are not getting any answers,
either people are not interested or they don't know what you are asking. I
would suggest that people don't know what your are asking. I can say I
don't have a clue what you want. you talk about unique numbers and two pair
numbers and two single numbers - frankly, none of it makes any sense in
explaining what want. Perhaps if you give a detailed example, that shows
what you have, what it means, and what you want to achieve - what the output
would look like based on what you have - you would get an answer.
 
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
 
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
 
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 said:
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
Click to expand...
 
Oops, now I left out the first two lines: Hopefully this will run if you
copy and paste it from the email.

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
 
Back
Top