Pick 5 numbers from the 6 groups

M

motilulla

Well-known Member
Joined
Feb 13, 2008
Messages
2,422
Office Version
  1. 2010
Using Excel 2010
Hello,

The macro below creates combinations of 5 numbers out of 1st 4 groups. (Group1, Group 2, Group 3 and Group 4…are shown in yellow)

But now I require modifications so it can create all possible combinations of 5 numbers using 6 groups.... From Group1 to Group6 (including 2 blue groups 5 and 6 also)

Please see the attached example below….

I tried to change (arrData = Range("A2:D4").Value ' Change here) To (arrData = Range("A2:F4").Value ' Change here) but seems it is design to create combinations only from 4 groups.

Please need help to modify the existing VBA; which cam work with present request. I want which can work with Excel version 2000 also.

VBA Code: 
Public Sub Five_numbers()

Range("G1:K50000").ClearContents

Dim dic As Object
Dim arrData, arrDec
Dim isUni As Boolean
Dim arr, arrB
Dim ID As String
Dim i1&, i2&, i3&, i4&, j&, c&, u&, k&
Set dic = CreateObject("Scripting.Dictionary")
ReDim arrDec(1 To 10000, 1 To 5)
ReDim arr(1 To 5)
arrData = Range("A2:D4").Value ' Change here

u = UBound(arrData, 1)
For i1 = 1 To u
    arr(1) = arrData(i1, 1)
    For i2 = 1 To u
        arr(2) = arrData(i2, 2)
        For i3 = 1 To u
            arr(3) = arrData(i3, 3)
            For i4 = 1 To u
                arr(4) = arrData(i4, 4)
                For c = 1 To 4
                    For j = 1 To u
                        isUni = False
                        Select Case c
                        Case 1
                            If j = i1 Then isUni = True
                        Case 2
                            If j = i2 Then isUni = True
                        Case 3
                            If j = i3 Then isUni = True
                        Case 4
                            If j = i4 Then isUni = True
                        End Select
                            If isUni = False Then
                            arr(5) = arrData(j, c)
                            arrB = Mysort(arr)
                           ID = arrB(1) & "|" & arrB(2) & "|" & arrB(3) & "|" & arrB(4) & "|" & arrB(5)
                            If dic.exists(ID) = False Then
                                k = k + 1
                                dic.Item(ID) = k
                                arrDec(k, 1) = arrB(1)
                                arrDec(k, 2) = arrB(2)
                                arrDec(k, 3) = arrB(3)
                                arrDec(k, 4) = arrB(4)
                                arrDec(k, 5) = arrB(5)
                            End If
                            End If
                    Next j
                Next c
            Next i4
        Next i3
    Next i2
Next i1
Range("G1").Resize(k, 5).Value = arrDec
MsgBox k
End Sub
Function Mysort(ByVal a As Variant) As Variant
Dim i As Long, ii As Long, s As Variant
For i = 1 To 4
    For ii = i + 1 To 5
        If a(i) > a(ii) Then
            s = a(i)
            a(i) = a(ii)
            a(ii) = s
        End If
    Next ii
Next i
Mysort = a
End Function

MrExcel Question.xlsm
ABCDEFGHIJK
1Group 1Group 2Group 3Group 4Group 5Group 6G11G12G21G31G41
2G11G21G31G41G61G71G11G13G21G31G41
3G12G22G32G42G62G72G11G21G22G31G41
4G13G23G33G43G63G73G11G21G23G31G41
5G11G21G31G32G41
6G11G21G31G33G41
7G11G21G31G41G42
8G11G21G31G41G43
9G11G12G21G31G42
10G11G13G21G31G42
11G11G21G22G31G42
12G11G21G23G31G42
13G11G21G31G32G42
14G11G21G31G33G42
15G11G21G31G42G43
16G11G12G21G31G43
17G11G13G21G31G43
18G11G21G22G31G43
19G11G21G23G31G43
20G11G21G31G32G43
21G11G21G31G33G43
22G11G12G21G32G41
23G11G13G21G32G41
24G11G21G22G32G41
25G11G21G23G32G41
26G11G21G32G33G41
27G11G21G32G41G42
28G11G21G32G41G43
29G11G12G21G32G42
30G11G13G21G32G42
31G11G21G22G32G42
32G11G21G23G32G42
33G11G21G32G33G42
34G11G21G32G42G43
35G11G12G21G32G43
Sheet10


Thank you.

Regards,

Moti
 
Sort by date Sort by votes
Flashbond said:
Here find the tested version. All works well:
VBA Code: 
Public Sub Five_numbers()

  Range("G:K").ClearContents

  Dim dic As Object
  Dim arrData, arrDec
  Dim isUni As Boolean
  Dim arr, arrB
  Dim ID As String
  Dim i1&, i2&, i3&, i4&, i5&, i6&, j&, c&, u&, k&
  Set dic = CreateObject("Scripting.Dictionary")
  ReDim arrDec(1 To 12000, 1 To 5)
  ReDim arr(1 To 7)
  arrData = Range("A2:F4").Value ' Change here

  u = UBound(arrData, 1)
  For i1 = 1 To u
    arr(1) = arrData(i1, 1)
    For i2 = 1 To u
      arr(2) = arrData(i2, 2)
      For i3 = 1 To u
        arr(3) = arrData(i3, 3)
        For i4 = 1 To u
          arr(4) = arrData(i4, 4)
          For i5 = 1 To u
            arr(5) = arrData(i5, 5)
            For i6 = 1 To u
              arr(6) = arrData(i6, 6)
              For c = 1 To 6
                For j = 1 To u
                  isUni = False
                  Select Case c
                  Case 1
                    If j = i1 Then isUni = True
                  Case 2
                    If j = i2 Then isUni = True
                  Case 3
                    If j = i3 Then isUni = True
                  Case 4
                    If j = i4 Then isUni = True
                  Case 5
                    If j = i5 Then isUni = True
                  Case 6
                    If j = i6 Then isUni = True
                  End Select
                  If isUni = False Then
                    arr(7) = arrData(j, c)
                    arrB = Mysort(arr)
                    ID = arrB(1) & "|" & arrB(2) & "|" & arrB(3) & "|" & arrB(4) & "|" & arrB(5) & "|" & arrB(6) & "|" & arrB(7)
                    If dic.exists(ID) = False Then
                      k = k + 1
                      dic.Item(ID) = k
                      arrDec(k, 1) = arrB(1)
                      arrDec(k, 2) = arrB(2)
                      arrDec(k, 3) = arrB(3)
                      arrDec(k, 4) = arrB(4)
                      arrDec(k, 5) = arrB(5)
                      arrDec(k, 4) = arrB(6)
                      arrDec(k, 5) = arrB(7)
                    End If
                  End If
                Next j
              Next c
            Next i6
          Next i5
        Next i4
      Next i3
    Next i2
  Next i1
  Range("G1").Resize(k, 5).Value = arrDec
  MsgBox k
End Sub
Function Mysort(ByVal a As Variant) As Variant
  Dim i As Long, ii As Long, s As Variant
  For i = 1 To 4
    For ii = i + 1 To 7
      If a(i) > a(ii) Then
        s = a(i)
        a(i) = a(ii)
        a(ii) = s
      End If
    Next ii
  Next i
  Mysort = a
End Function
Click to expand...
Hello Flashbond, still you can check there are all in blue taken 1 number from each group and yellow have 2 numbers from each group

MrExcel Question.xlsm
ABCDEFGHIJK
1Group 1Group 2Group 3Group 4Group 5Group 6G11G12G21G71G41
2G11G21G31G41G61G71G11G13G21G71G41
3G12G22G32G42G62G72G11G21G22G71G41
4G13G23G33G43G63G73G11G21G23G71G41
5G11G21G31G71G41
6G11G21G31G71G41
7G11G21G23G72G41
8G11G21G31G72G41
9G11G21G31G72G41
10G11G21G31G72G42
11G11G21G31G72G43
12G11G21G31G72G62
13G11G21G31G72G63
14G11G21G31G72G71
15G11G21G31G72G73
16G11G12G21G73G41
17G11G13G21G73G41
18G11G21G22G73G41
19G11G21G23G73G41
20G11G21G31G73G41
21G11G21G31G73G41
22G11G21G31G73G42
23G11G21G31G73G43
24G11G21G31G73G62
25G11G21G31G73G63
26G11G21G31G71G43
27G11G21G31G71G61
28G11G21G31G71G63
29G11G21G31G73G42
30G11G21G31G73G43
31G11G21G31G73G61
32G13G23G32G73G62
33G13G23G33G73G42
34G13G23G33G73G43
35G13G23G33G71G61
36G13G23G33G73G72
Sheet10


Thank you

My Best Regards,
Moti
 
Upvote 0

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
One question. Is it ok to have 2 elements from two groups like:
G11 G12 G22 G23 G41

Or 2 elemets will be picked only from one group and the rest will be single elements?
Ex: G11 G12 G21 G31 G41
 
Upvote 1
Flashbond said:
One question. Is it ok to have 2 elements from two groups like:
G11 G12 G22 G23 G41

Or 2 elemets will be picked only from one group and the rest will be single elements?
Ex: G11 G12 G21 G31 G41
Click to expand...
Hello Flashbond, thank you for asking a question simplifying in an easy way that is perfect…here is an answer

Or 2 elemets will be picked only from one group and the rest will be single elements?
Ex: G11 G12 G21 G31 G41…this is exactly what I need please make this one.

One question. Is it ok to have 2 elements from two groups like:
G11 G12 G22 G23 G41…you make me greedy giving me this option pleas it would be kind of you if you can make this also.

Have a nice day.

My Best Regards,
Moti :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
Previously working very complex VBA now stopped
Replies
7
Views
532
Alex Blakenburg
A
K
  • Solved
Using VBA to select a color coded cell
2
Replies
11
Views
933
Alex Blakenburg
A
K
  • Solved
Update to existing Move data macro
2
Replies
11
Views
732
Alex Blakenburg
A
M
  • Question Question
Operational Risk Methodology on VBA
Replies
0
Views
81
Mazurofgod
M
F
  • Question Question
How to get optionbutton values from two different groups
Replies
2
Views
543
NoSparks
N

Forum statistics

Threads
1,223,904
Messages
6,175,295
Members
452,631
Latest member
a_potato

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top