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
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Sort by date Sort by votes
A bit sketch but does the job!
VBA Code: 
Sub combinations()
  Dim items() As Variant
  Dim combLen As Long
  Dim myRange As Range
  Dim itemsLen As Long
  combLen = 5
  
  itemsLen = (Cells(Rows.count, 1).End(xlUp).Row - 1) * Cells(1, Columns.count).End(xlToLeft).Column
  ReDim items(1 To itemsLen)
  i = 1
  For c = 1 To Cells(1, Columns.count).End(xlToLeft).Column
    For r = 2 To Cells(Rows.count, 1).End(xlUp).Row
      items(i) = Cells(r, c)
      i = i + 1
    Next
  Next

  items = binomial(items, combLen)
  Application.ScreenUpdating = False
  For i = 1 To nChooseK(itemsLen, combLen)
   For j = 1 To combLen
     Cells(i, j).Offset(, 6).Value = items(i, j)
   Next
  Next
  Application.ScreenUpdating = True
End Sub
Function binomial(ByRef v() As Variant, r As Long) As Variant()
  Dim i As Long, k As Long, z() As Variant, comboMatrix() As Variant
  Dim numRows As Long, numIter As Long, n As Long, count As Long
    
  count = 1
  n = UBound(v)
  numRows = nChooseK(n, r)
  
  ReDim z(1 To r)
  ReDim comboMatrix(1 To numRows, 1 To r)
  For i = 1 To r
    z(i) = i
  Next
  Do While (count <= numRows)
    numIter = n - z(r) + 1
    For i = 1 To numIter
      For k = 1 To r
        comboMatrix(count, k) = v(z(k))
      Next
      count = count + 1
     z(r) = z(r) + 1
    Next
    For i = r - 1 To 1 Step -1
      If Not (z(i) = (n - r + i)) Then
        z(i) = z(i) + 1
        For k = (i + 1) To r
          z(k) = z(k - 1) + 1
        Next
        Exit For
      End If
    Next
  Loop
  binomial = comboMatrix
End Function
Function nChooseK(n As Long, k As Long) As Long
  Dim temp As Double, i As Long
  temp = 1
  For i = 1 To k
    temp = temp * (n - k + i) / i
  Next
  nChooseK = CLng(temp)
End Function
 
Upvote 0
Flashbond said:
A bit sketch but does the job!
VBA Code: 
Sub combinations()
  Dim items() As Variant
  Dim combLen As Long
  Dim myRange As Range
  Dim itemsLen As Long
  combLen = 5
 
  itemsLen = (Cells(Rows.count, 1).End(xlUp).Row - 1) * Cells(1, Columns.count).End(xlToLeft).Column
  ReDim items(1 To itemsLen)
  i = 1
  For c = 1 To Cells(1, Columns.count).End(xlToLeft).Column
    For r = 2 To Cells(Rows.count, 1).End(xlUp).Row
      items(i) = Cells(r, c)
      i = i + 1
    Next
  Next

  items = binomial(items, combLen)
  Application.ScreenUpdating = False
  For i = 1 To nChooseK(itemsLen, combLen)
   For j = 1 To combLen
     Cells(i, j).Offset(, 6).Value = items(i, j)
   Next
  Next
  Application.ScreenUpdating = True
End Sub
Function binomial(ByRef v() As Variant, r As Long) As Variant()
  Dim i As Long, k As Long, z() As Variant, comboMatrix() As Variant
  Dim numRows As Long, numIter As Long, n As Long, count As Long
   
  count = 1
  n = UBound(v)
  numRows = nChooseK(n, r)
 
  ReDim z(1 To r)
  ReDim comboMatrix(1 To numRows, 1 To r)
  For i = 1 To r
    z(i) = i
  Next
  Do While (count <= numRows)
    numIter = n - z(r) + 1
    For i = 1 To numIter
      For k = 1 To r
        comboMatrix(count, k) = v(z(k))
      Next
      count = count + 1
     z(r) = z(r) + 1
    Next
    For i = r - 1 To 1 Step -1
      If Not (z(i) = (n - r + i)) Then
        z(i) = z(i) + 1
        For k = (i + 1) To r
          z(k) = z(k - 1) + 1
        Next
        Exit For
      End If
    Next
  Loop
  binomial = comboMatrix
End Function
Function nChooseK(n As Long, k As Long) As Long
  Dim temp As Double, i As Long
  temp = 1
  For i = 1 To k
    temp = temp * (n - k + i) / i
  Next
  nChooseK = CLng(temp)
End Function
Click to expand...
Hello Flashbond, really thank you for looking into my request I appreciate your hard work…2 things 1st the macro take time to run some time it freeze excel computer need to shut excel…2nd some time if it has finished to generate all sets I noticed it is picking 3 number from the each group it must pick max 2 from the group as previous macro condition even adding 2 more groups.

Please can you take a look?

My Best Regards,
Moti
 
Upvote 0
ı fyou were hapy with the old macro and your only concern is to extend the range to column F, then this should work:
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&, 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: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 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
The code has a comment says "Change here" which should be a tip for you to define your range.
 
Upvote 0
Flashbond said:
ı fyou were hapy with the old macro and your only concern is to extend the range to column F, then this should work:
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&, j&, c&, u&, k&
Set dic = CreateObject("Scripting.Dictionary")
ReDim arrDec(1 To 10000, 1 To 5)
ReDim arr(1 To 5)

[/QUOTE]

[QUOTE="Flashbond, post: 6059003, member: 143009"]
arrData = Range("A2:F4").Value ' Change here

The code has a comment says "Change here" which should be a tip for you to define your range.
Click to expand...

@Phuoc, did resolve my query pick 5 numbers from 4 groups limiting max 2 numbers from any group and rest 3 from other groups. Now I want must be the same conditions but extending 2 more groups “I mean here pick 5 numbers from 6 groups limiting max 2 numbers from any group and rest 3 from other extended groups.” You can see query was solved under below given link.

www.mrexcel.com

Make possible set of 5 numbers using 4 groups.

Hello, I have got 4 groups of 5 numbers as follow... Group1-In the column "B" with 5 numbers Group2-In the column "C" with 5 numbers Group3-In the column "D" with 5 numbers Group4-In the column "E" with 5 numbers In fact using 20 numbers and making sets of numbers there must be total...
www.mrexcel.com www.mrexcel.com

The code has a comment says "Change here" which should be a tip for you to define your range.

Hello Flashbond, thank you once again regarding I did comment in the opening post it does not work you did change the range but you did not saw it does not pick any numbers from 2 extended groups this macro need a tweaks to work with current ranges with extended 2 groups also.

Please try to create combinations with your change range you will see nothing happens it works in the same way with only 4 groups.

My Best Regards,
Moti
 
Upvote 0
Ok I have tested. It is impossible to check all combinations but this should work. The problem with this code is, it is fast but it doesn't scale well for the needs like you've already mentioned. It will need additional tweaks if you change the column or row size.
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
                   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 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 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
 
Upvote 0
Flashbond said:
Ok I have tested. It is impossible to check all combinations but this should work. The problem with this code is, it is fast but it doesn't scale well for the needs like you've already mentioned. It will need additional tweaks if you change the column or row size.
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
                   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 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 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
Click to expand...
Hello Flashbond, I am very grateful to you for helping me to solve this now yes it pick number from all groups but does not accomplish conditions to pick strictly only 2 numbers from 1 of each group...Please Check Below output yellow are ok but blue no. It is picking 1 from group.

MrExcel Question.xlsm
ABCDEFGHIJK
1Group 1Group 2Group 3Group 4Group 5Group 6G11G12G21G31G41
2G11G21G31G41G61G71G11G13G21G31G41
3G12G22G32G42G62G72G11G21G22G31G41
4G13G23G33G43G63G73G11G21G23G31G41
5G11G21G31G32G41
6G11G21G31G33G41
7G11G21G31G41G42
8
9G11G21G31G41G63
10
11G11G21G31G42G63
12
13G11G21G31G32G43
14G11G21G31G33G43
15
16G13G23G33G41G73
17G13G23G33G42G43
18
19G13G23G33G43G73
Sheet10 (2)


Yes there is no problem to changing output to any columns if it requires getting as I want combinations with set of 5 out of 6 groups with condition pick max only 2 numbers from any groups.

My Best Regards,
Moti
 
Upvote 0
Sorry for that. I am not familiar with this particular code. Try this but I have not tested:
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)
                     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 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 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
 
Upvote 0
Flashbond said:
Sorry for that. I am not familiar with this particular code. Try this but I have not tested:
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)
                     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 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 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
Click to expand...
Hello Flashbond, now it is picking 1 number from each group it has to be minimum/maximum 2 numbers from each group.

Please check it. Thank you for your intention to help I do appreciate.

My Best Regards,
Moti
 
Upvote 0
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
 
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
510
Alex Blakenburg
A
K
  • Solved
Using VBA to select a color coded cell
2
Replies
11
Views
900
Alex Blakenburg
A
K
  • Solved
Update to existing Move data macro
2
Replies
11
Views
725
Alex Blakenburg
A
F
  • Question Question
How to get optionbutton values from two different groups
Replies
2
Views
536
NoSparks
N
G
  • Question Question
Why does #VALUE error in VBA function occur when creating a ReDim Matrix of Stock prices from a Named Range?
Replies
2
Views
69
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,223,236
Messages
6,170,912
Members
452,366
Latest member
TePunaBloke

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