All possible combinations without repeating

[rdshadden]

I would like to have a VBA code that will allow me to determine all combinations of a fixed number of athletes (m) in which m will change from time to time. I need to generate all combinations of n groups with o per group. For example, I would like to make 4 groups of 2 per group, or 3 groups of 4 per group, or 4 groups of 3 per group and so on. It should be flexible enough to ignore the extra athletes that are not a part of a particular combination. That is, if I am making 4 groups of 2 per group out of m=9 athletes I would get all combinations with the one of the athletes ignored. The best solution would to just use numbers (1, 2, 3, ...) for each athlete and get the following as an example set of data for 4 groups of 2 per group:

1 2, 4 6, 3 7, 5 9

where 8 in this particular combination was ignored but would be included in subsequent combinations with another athlete ignored.

 

[pbornemeier]

The last post in this thread has a link to code that makes a start at doing what you want.

 

[rdshadden]

The last post in this thread has a link to code that makes a start at doing what you want.

I tried the code using the example data from the post and it doesn't work. I am getting a compile error on UBound(Buffer()) statement in the SavePermutation subroutine although I changed the Cells.Count to Cells.CountLarge as recommended in the post for Excel 2007 and later. I am using 2010.

I have cell A1 = C, cell A2 = 2, cell A3 = A, cell A4 = B, and cell A5 = C. I selected cell A1 prior to running the code and no dice in running the code successfully.

 

[pbornemeier]

I made a few trivial modifications to the original (very nifty) code and have included it below:

Option Explicit

'http://answers.microsoft.com/en-us/office/forum/office_2010-excel/code-for-permtations-combinations/7b766aa5-5998-4905-8eb1-522bfe373d25
'A1 = C for Combinations or P for permutations
'A2 = 2 number to combine or permute
'A3 = A First item
'A4 = B Second item
'Continue down column A for as many items as required

 Dim vAllItems As Variant
 Dim Buffer() As String
 Dim BufferPtr As Long
 Dim Results As Worksheet
 '
 '  Posted by Myrna Larson
 '  July 25, 2000
 '  Microsoft.Public.Excel.Misc
 '  Subject:  Combin

Sub ListPermutations()
   Dim Rng As Range
   Dim PopSize As Integer
   Dim SetSize As Integer
   Dim Which As String
   Dim N As Double
   Const BufferSize As Long = 4096
   
   Range("A1").Select 'Added by PAB
   
   Set Rng = Selection.Columns(1).Cells
   If Rng.Cells.count = 1 Then
     Set Rng = Range(Rng, Rng.End(xlDown))
   End If
   PopSize = Rng.Cells.CountLarge - 2
   If PopSize < 2 Then GoTo DataError
   SetSize = Rng.Cells(2).Value
   If SetSize > PopSize Then GoTo DataError
   Which = UCase$(Rng.Cells(1).Value)
   Select Case Which
   Case "C"
     N = Application.WorksheetFunction.Combin(PopSize, SetSize)
   Case "P"
     N = Application.WorksheetFunction.Permut(PopSize, SetSize)
   Case Else
     GoTo DataError
   End Select
   If N > Cells.CountLarge Then GoTo DataError
   Application.ScreenUpdating = False
   Set Results = Worksheets.Add
   vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
   ReDim Buffer(1 To BufferSize) As String
   BufferPtr = 0
   If Which = "C" Then
     AddCombination PopSize, SetSize
   Else
     AddPermutation PopSize, SetSize
   End If
   vAllItems = 0
   
   'Added by PAB
   Rng.Copy Destination:=Results.Range("C1")
   Select Case Which
   Case "C"
     Results.Range("C1").Value = N & " Combinations of"
   Case "P"
     Results.Range("C1").Value = N & " Permutations of"
   Case Else
     GoTo DataError
   End Select
   Results.Range("C2").Value = PopSize & " items below taken " & SetSize & " at a time."
   'End add by PAB
   
   Application.ScreenUpdating = True
   Exit Sub
DataError:
   If N = 0 Then
     Which = "Enter your data in a vertical range of at least 4 cells. " _
       & String$(2, 10) _
       & "Top cell must contain the letter C or P, 2nd cell is the number " _
       & "of items in a subset, the cells below are the values from which " _
       & "the subset is to be chosen."
   Else
     Which = "This requires " & Format$(N, "#,##0") & _
       " cells, more than are available on the worksheet!"
   End If
   MsgBox Which, vbOKOnly, "DATA ERROR"
   Exit Sub
 End Sub
 Private Sub AddPermutation(Optional PopSize As Integer = 0, _
   Optional SetSize As Integer = 0, _
   Optional NextMember As Integer = 0)
   Static iPopSize As Integer
   Static iSetSize As Integer
   Static SetMembers() As Integer
   Static Used() As Integer
   Dim i As Integer
   If PopSize <> 0 Then
     iPopSize = PopSize
     iSetSize = SetSize
     ReDim SetMembers(1 To iSetSize) As Integer
     ReDim Used(1 To iPopSize) As Integer
     NextMember = 1
   End If
   For i = 1 To iPopSize
     If Used(i) = 0 Then
       SetMembers(NextMember) = i
       If NextMember <> iSetSize Then
         Used(i) = True
         AddPermutation , , NextMember + 1
         Used(i) = False
       Else
         SavePermutation SetMembers()
       End If
     End If
   Next i
   If NextMember = 1 Then
     SavePermutation SetMembers(), True
     Erase SetMembers
     Erase Used
   End If
 End Sub  'AddPermutation
 Private Sub AddCombination(Optional PopSize As Integer = 0, _
   Optional SetSize As Integer = 0, _
   Optional NextMember As Integer = 0, _
   Optional NextItem As Integer = 0)
   Static iPopSize As Integer
   Static iSetSize As Integer
   Static SetMembers() As Integer
   Dim i As Integer
   If PopSize <> 0 Then
     iPopSize = PopSize
     iSetSize = SetSize
     ReDim SetMembers(1 To iSetSize) As Integer
     NextMember = 1
     NextItem = 1
   End If
   For i = NextItem To iPopSize
     SetMembers(NextMember) = i
     If NextMember <> iSetSize Then
       AddCombination , , NextMember + 1, i + 1
     Else
       SavePermutation SetMembers()
     End If
   Next i
   If NextMember = 1 Then
     SavePermutation SetMembers(), True
     Erase SetMembers
   End If
 End Sub  'AddCombination
 Private Sub SavePermutation(ItemsChosen() As Integer, _
   Optional FlushBuffer As Boolean = False)
   Dim i As Integer, sValue As String
   Static RowNum As Long, ColNum As Long
   If RowNum = 0 Then RowNum = 1
   If ColNum = 0 Then ColNum = 1
   If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
     If BufferPtr > 0 Then
       If (RowNum + BufferPtr - 1) > Rows.count Then
         RowNum = 1
         ColNum = ColNum + 1
         If ColNum > 256 Then Exit Sub
       End If
       Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
         = Application.WorksheetFunction.Transpose(Buffer())
       RowNum = RowNum + BufferPtr
     End If
     BufferPtr = 0
     If FlushBuffer = True Then
       Erase Buffer
       RowNum = 0
       ColNum = 0
       Exit Sub
     Else
       ReDim Buffer(1 To UBound(Buffer))
     End If
   End If
   'construct the next set
   For i = 1 To UBound(ItemsChosen)
     sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
   Next i
   'and save it in the buffer
   BufferPtr = BufferPtr + 1
   Buffer(BufferPtr) = Mid$(sValue, 3)
 End Sub  'SavePermutation

 

[rdshadden]

I made a few trivial modifications to the original (very nifty) code and have included it below:

Option Explicit

'http://answers.microsoft.com/en-us/office/forum/office_2010-excel/code-for-permtations-combinations/7b766aa5-5998-4905-8eb1-522bfe373d25
'A1 = C for Combinations or P for permutations
'A2 = 2 number to combine or permute
'A3 = A First item
'A4 = B Second item
'Continue down column A for as many items as required

 Dim vAllItems As Variant
 Dim Buffer() As String
 Dim BufferPtr As Long
 Dim Results As Worksheet
 '
 '  Posted by Myrna Larson
 '  July 25, 2000
 '  Microsoft.Public.Excel.Misc
 '  Subject:  Combin

Sub ListPermutations()
   Dim Rng As Range
   Dim PopSize As Integer
   Dim SetSize As Integer
   Dim Which As String
   Dim N As Double
   Const BufferSize As Long = 4096
   
   Range("A1").Select 'Added by PAB
   
   Set Rng = Selection.Columns(1).Cells
   If Rng.Cells.count = 1 Then
     Set Rng = Range(Rng, Rng.End(xlDown))
   End If
   PopSize = Rng.Cells.CountLarge - 2
   If PopSize < 2 Then GoTo DataError
   SetSize = Rng.Cells(2).Value
   If SetSize > PopSize Then GoTo DataError
   Which = UCase$(Rng.Cells(1).Value)
   Select Case Which
   Case "C"
     N = Application.WorksheetFunction.Combin(PopSize, SetSize)
   Case "P"
     N = Application.WorksheetFunction.Permut(PopSize, SetSize)
   Case Else
     GoTo DataError
   End Select
   If N > Cells.CountLarge Then GoTo DataError
   Application.ScreenUpdating = False
   Set Results = Worksheets.Add
   vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
   ReDim Buffer(1 To BufferSize) As String
   BufferPtr = 0
   If Which = "C" Then
     AddCombination PopSize, SetSize
   Else
     AddPermutation PopSize, SetSize
   End If
   vAllItems = 0
   
   'Added by PAB
   Rng.Copy Destination:=Results.Range("C1")
   Select Case Which
   Case "C"
     Results.Range("C1").Value = N & " Combinations of"
   Case "P"
     Results.Range("C1").Value = N & " Permutations of"
   Case Else
     GoTo DataError
   End Select
   Results.Range("C2").Value = PopSize & " items below taken " & SetSize & " at a time."
   'End add by PAB
   
   Application.ScreenUpdating = True
   Exit Sub
DataError:
   If N = 0 Then
     Which = "Enter your data in a vertical range of at least 4 cells. " _
       & String$(2, 10) _
       & "Top cell must contain the letter C or P, 2nd cell is the number " _
       & "of items in a subset, the cells below are the values from which " _
       & "the subset is to be chosen."
   Else
     Which = "This requires " & Format$(N, "#,##0") & _
       " cells, more than are available on the worksheet!"
   End If
   MsgBox Which, vbOKOnly, "DATA ERROR"
   Exit Sub
 End Sub
 Private Sub AddPermutation(Optional PopSize As Integer = 0, _
   Optional SetSize As Integer = 0, _
   Optional NextMember As Integer = 0)
   Static iPopSize As Integer
   Static iSetSize As Integer
   Static SetMembers() As Integer
   Static Used() As Integer
   Dim i As Integer
   If PopSize <> 0 Then
     iPopSize = PopSize
     iSetSize = SetSize
     ReDim SetMembers(1 To iSetSize) As Integer
     ReDim Used(1 To iPopSize) As Integer
     NextMember = 1
   End If
   For i = 1 To iPopSize
     If Used(i) = 0 Then
       SetMembers(NextMember) = i
       If NextMember <> iSetSize Then
         Used(i) = True
         AddPermutation , , NextMember + 1
         Used(i) = False
       Else
         SavePermutation SetMembers()
       End If
     End If
   Next i
   If NextMember = 1 Then
     SavePermutation SetMembers(), True
     Erase SetMembers
     Erase Used
   End If
 End Sub  'AddPermutation
 Private Sub AddCombination(Optional PopSize As Integer = 0, _
   Optional SetSize As Integer = 0, _
   Optional NextMember As Integer = 0, _
   Optional NextItem As Integer = 0)
   Static iPopSize As Integer
   Static iSetSize As Integer
   Static SetMembers() As Integer
   Dim i As Integer
   If PopSize <> 0 Then
     iPopSize = PopSize
     iSetSize = SetSize
     ReDim SetMembers(1 To iSetSize) As Integer
     NextMember = 1
     NextItem = 1
   End If
   For i = NextItem To iPopSize
     SetMembers(NextMember) = i
     If NextMember <> iSetSize Then
       AddCombination , , NextMember + 1, i + 1
     Else
       SavePermutation SetMembers()
     End If
   Next i
   If NextMember = 1 Then
     SavePermutation SetMembers(), True
     Erase SetMembers
   End If
 End Sub  'AddCombination
 Private Sub SavePermutation(ItemsChosen() As Integer, _
   Optional FlushBuffer As Boolean = False)
   Dim i As Integer, sValue As String
   Static RowNum As Long, ColNum As Long
   If RowNum = 0 Then RowNum = 1
   If ColNum = 0 Then ColNum = 1
   If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
     If BufferPtr > 0 Then
       If (RowNum + BufferPtr - 1) > Rows.count Then
         RowNum = 1
         ColNum = ColNum + 1
         If ColNum > 256 Then Exit Sub
       End If
       Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
         = Application.WorksheetFunction.Transpose(Buffer())
       RowNum = RowNum + BufferPtr
     End If
     BufferPtr = 0
     If FlushBuffer = True Then
       Erase Buffer
       RowNum = 0
       ColNum = 0
       Exit Sub
     Else
       ReDim Buffer(1 To UBound(Buffer))
     End If
   End If
   'construct the next set
   For i = 1 To UBound(ItemsChosen)
     sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
   Next i
   'and save it in the buffer
   BufferPtr = BufferPtr + 1
   Buffer(BufferPtr) = Mid$(sValue, 3)
 End Sub  'SavePermutation

This is working FANTASTICALLY. Thanks for the help. It will make my setting up random player practices much easier. I was writing code to take the reduced Latin Squares for 13 and removing select player numbers and making multiple chart for the various combinations. This was not nearly as hard to do as the above code. Now all I have to do is align each grouping with other possible groupings and just cross out the ones that I have used in a particular practice session so that I will not repeat it in subsequent practices. Again, thanks for the work.