Make possible set of 5 numbers using 5 groups

[motilulla]

Using Excel 2010
Hello,

I am using @[B]Phuoc[/B], VBA solution from #post17 linked below
Make possible set of 5 numbers using 4 groups. | Page 2 | MrExcel Message Board
This does create 5 numbers perfectly out of 4 groups, picking 2 numbers from any of 4 groups and 3 numbers from rest of 3 groups.

But now I need that it must create 5 numbers from 5 groups picking 1 number from each group.

Please see the attached example below I am not sure how much combinations will be made using 5 groups.
Please suggest VBA, I want which can work with Excel version 2000 also.

MrExcel Question.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L
1
2
3
4		Group 1	Group 2	Group 3	Group 4	Group 5		n1	n2	n3	n4	n5
5		1	17	27	44	65		1	17	27	44	65
6		3	18	32	45	66		1	17	27	44	66
7		5	22	36	47	67		1	17	27	44	67
8		8	24	42	48	68		1	17	27	44	68
9		12	25	43	50	69		1	17	27	44	69
10								1	17	27	45	65
11								1	17	27	45	66
12								1	17	27	45	67
13								1	17	27	45	68
14								1	17	27	45	69
Sheet1

Thank you all.

Regards,
Moti

 

[DanteAmor]

Hi @motilulla , thanks for posting on the board.

Try the following code uses recursion to perform the combinations. You can put matrices from 2x2, o 3x3 o 5x5 o to 7x7. The 8x8 matrix is not possible anymore, because it uses more than 16 million combinations, and it couldn't be put in the same column, unless it is divided into several columns, but that would be another story.

The matrix must have the same number of rows and columns.

Put the range of cells in this line, for your example "B5:F9"

a = Range("B5:F9").Value

Put all the code in a module and run the groups macro.
The result in cell K5 onwards.

Dim a As Variant, b As Variant   'These variables at the beginning of all code
Dim j As Long, k As Long

Sub groups()
  Dim x As Long, y As Long
  
  a = Range("B5:F9").Value
  ReDim b(1 To UBound(a, 1) ^ UBound(a, 1), 1 To UBound(a, 2))
  
  k = 1
  j = 1
  Call recursion(1, 1)
  
  For x = 2 To UBound(b, 1)
    For y = 1 To UBound(b, 2)
      If b(x, y) = "" Then b(x, y) = b(x - 1, y)
    Next
  Next
  Range("K5").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Sub recursion(fila, col)
  Dim collec As New Collection, itm As Variant, i&
  
  For i = 1 To UBound(a, 1)
    collec.Add a(i, col)
  Next

  For Each itm In collec
    b(j, k) = itm
    k = k + 1
    If k < UBound(a, 1) + 1 Then
      Call recursion(1, k)
    End If
    k = k - 1
    If k = UBound(a, 1) Then j = j + 1
  Next
End Sub

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------

 

[motilulla]

Hi @motilulla , thanks for posting on the board.

Try the following code uses recursion to perform the combinations. You can put matrices from 2x2, o 3x3 o 5x5 o to 7x7. The 8x8 matrix is not possible anymore, because it uses more than 16 million combinations, and it couldn't be put in the same column, unless it is divided into several columns, but that would be another story.

The matrix must have the same number of rows and columns.

Put the range of cells in this line, for your example "B5:F9"

a = Range("B5:F9").Value

Put all the code in a module and run the groups macro.
The result in cell K5 onwards.

Dim a As Variant, b As Variant   'These variables at the beginning of all code
Dim j As Long, k As Long

Sub groups()
  Dim x As Long, y As Long
 
  a = Range("B5:F9").Value
  ReDim b(1 To UBound(a, 1) ^ UBound(a, 1), 1 To UBound(a, 2))
 
  k = 1
  j = 1
  Call recursion(1, 1)
 
  For x = 2 To UBound(b, 1)
    For y = 1 To UBound(b, 2)
      If b(x, y) = "" Then b(x, y) = b(x - 1, y)
    Next
  Next
  Range("K5").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Sub recursion(fila, col)
  Dim collec As New Collection, itm As Variant, i&
 
  For i = 1 To UBound(a, 1)
    collec.Add a(i, col)
  Next

  For Each itm In collec
    b(j, k) = itm
    k = k + 1
    If k < UBound(a, 1) + 1 Then
      Call recursion(1, k)
    End If
    k = k - 1
    If k = UBound(a, 1) Then j = j + 1
  Next
End Sub

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------

Hello [B]DanteAmor[/B], first of all I want to appreciate your kind help.

Yes it does work perfect with the given example in the #post1 pick 1 number from the each group and create the 3124 combinations.

But it restrict to me I cannot chose to put different amount of numbers in the each of the groups for example 6 numbers in the group1, 4 numbers in the group 2 and so on.

What if I place only 3 numbers in each group so far for that range will be used B5:F7 it give me only 25 combinations only within 3 columns K, L and M of 3 numbers only. Please is it any way that could give me combination of 5 numbers?

Good Luck,

Kind Regards,
Moti

 

[DanteAmor]

What if I place only 3 numbers in each group so far for that range will be used B5:F7 it give me only 25 combinations only within 3 columns K, L and M of 3 numbers only. Please is it any way that could give me combination of 5 numbers?

It's not possible, the layout is for a 5x5 matrix with 5 output columns.
I would have to spend more time trying to modify the code.
But you would have to be more specific, since in your original requirement you only mention 5x5 and a 5 column output.

Only if this is the case, the macro works for a 3x3 matrix and a 3 column output.
A 4x4 matrix and a 4 column output.
A 6x6 matrix and a 6 column output.

If you need other requirements, I insist, you must be more specific in your original publication.

Hopefully someone else can help you with a macro with flexibility you didn't specify.

For me the issue is resolved for the original post.

Good luck.

Sincerely
Dante Amor

 

[Eric W]

Consider:

Sub test1()
Dim UpperLeft As Range, Results As Range
Dim NumCols As Long, combos As Long, maxrow As Long, c As Long, r As Long
Dim cap() As Long, ix() As Long, output() As Variant, MyData As Variant

    Set UpperLeft = Range("B4")
    Set Results = Range("H4")
    
    NumCols = UpperLeft.End(xlToRight).Column - UpperLeft.Column + 1
    ReDim ix(1 To NumCols)
    ReDim cap(1 To NumCols)
    combos = 1
    maxrow = 0
    
    For c = 1 To NumCols
        cap(c) = UpperLeft.Offset(, c - 1).End(xlDown).Row - UpperLeft.Row
        combos = combos * cap(c)
        maxrow = IIf(maxrow > cap(c), maxrow, cap(c))
        ix(c) = 1
    Next c
        
    If combos > Rows.Count - Results.Row Then
        MsgBox "Insufficient rows to display all results"
        Exit Sub
    End If
    
    ReDim output(1 To combos, 1 To NumCols)
    MyData = UpperLeft.Offset(1).Resize(maxrow, NumCols).Value
    
    r = 1
    
NextItem:
    For c = 1 To NumCols
        output(r, c) = MyData(ix(c), c)
    Next c
    r = r + 1
    
    For c = NumCols To 1 Step -1
        ix(c) = ix(c) + 1
        If ix(c) <= cap(c) Then GoTo NextItem:
        ix(c) = 1
    Next c
    
    Results.Resize(, NumCols) = UpperLeft.Resize(, NumCols).Value
    Results.Offset(1).Resize(combos, NumCols) = output
    
End Sub

Change the "Set UpperLeft" line to refer to the upper left cell of your input data, B4 in your example. Change the "Set Results" line to refer to where you want the results to go, H4 in your example.

This macro will work for any number of columns, with any number of items in each column. But don't get carried away, it doesn't take much to get too many results to display on one sheet.

Two quick thoughts:
First, there is almost never any good reason to list all these results. If you're doing any kind of analysis, it's better to do it while creating the results and you don't need to display them. If you're not doing analysis, then all you see is row after row of results with no way to identify any rows of interest, so they all blur together.

Next, I'm aware that it's not always easy to search this forum, but this particular question has been asked and answered many times. I've provided this exact macro several times myself. It's probably worthwhile for you to spend some time learning how to search the forum better, using different search terms, or checking the "Similar threads" section.

Anyway, hope this helps!

 

[motilulla]

I would have to spend more time trying to modify the code.
But you would have to be more specific, since in your original requirement you only mention 5x5 and a 5 column output.

Hello DanteAmor, I am very sorry; really some idea comes after getting solution and trying it in a different ways which has happen with me in this case.

For me the issue is resolved for the original post.

Good luck.

Sincerely
Dante Amor

I appreciate your time and giving a solution as per my request by opening post. Yes I accept by my side also it were solved as per my appeal 100%.

Thank you so much.

Have a nice Day and Good Luck!

My Best Regards,
Moti

 

[motilulla]

Consider:

Sub test1()
Dim UpperLeft As Range, Results As Range
Dim NumCols As Long, combos As Long, maxrow As Long, c As Long, r As Long
Dim cap() As Long, ix() As Long, output() As Variant, MyData As Variant

    Set UpperLeft = Range("B4")
    Set Results = Range("H4")
   
    NumCols = UpperLeft.End(xlToRight).Column - UpperLeft.Column + 1
    ReDim ix(1 To NumCols)
    ReDim cap(1 To NumCols)
    combos = 1
    maxrow = 0
   
    For c = 1 To NumCols
        cap(c) = UpperLeft.Offset(, c - 1).End(xlDown).Row - UpperLeft.Row
        combos = combos * cap(c)
        maxrow = IIf(maxrow > cap(c), maxrow, cap(c))
        ix(c) = 1
    Next c
       
    If combos > Rows.Count - Results.Row Then
        MsgBox "Insufficient rows to display all results"
        Exit Sub
    End If
   
    ReDim output(1 To combos, 1 To NumCols)
    MyData = UpperLeft.Offset(1).Resize(maxrow, NumCols).Value
   
    r = 1
   
NextItem:
    For c = 1 To NumCols
        output(r, c) = MyData(ix(c), c)
    Next c
    r = r + 1
   
    For c = NumCols To 1 Step -1
        ix(c) = ix(c) + 1
        If ix(c) <= cap(c) Then GoTo NextItem:
        ix(c) = 1
    Next c
   
    Results.Resize(, NumCols) = UpperLeft.Resize(, NumCols).Value
    Results.Offset(1).Resize(combos, NumCols) = output
   
End Sub

Change the "Set UpperLeft" line to refer to the upper left cell of your input data, B4 in your example. Change the "Set Results" line to refer to where you want the results to go, H4 in your example.

This macro will work for any number of columns, with any number of items in each column. But don't get carried away, it doesn't take much to get too many results to display on one sheet.

Anyway, hope this helps!

Hello Eric W, I appreciate your help for giving a solution on my second request of post#3. I tried and it looks versatile and it does works in the any numbers of in the columns it is an ideal solution.

Consider:

Sub test1()
Dim UpperLeft As Range, Results As Range
Dim NumCols As Long, combos As Long, maxrow As Long, c As Long, r As Long
Dim cap() As Long, ix() As Long, output() As Variant, MyData As Variant
End Sub

Two quick thoughts:
First, there is almost never any good reason to list all these results. If you're doing any kind of analysis, it's better to do it while creating the results and you don't need to display them. If you're not doing analysis, then all you see is row after row of results with no way to identify any rows of interest, so they all blur together.

Next, I'm aware that it's not always easy to search this forum, but this particular question has been asked and answered many times. I've provided this exact macro several times myself. It's probably worthwhile for you to spend some time learning how to search the forum better, using different search terms, or checking the "Similar threads" section.

Anyway, hope this helps!

Sure I will keep in my mind your advice and will follow-up. Thank you for all your help

Have a nice Day and Good Luck!

My Best Regards,
Moti