Need help with Combinations, told to come here

Math Question for football pool

--------------------------------------------------------------------------------

Does anyone know where I can obtain software that would enable me to print out all 4,960 3 team football combinations using the 32 NFL teams (Order does not matter), it would be used for a pool I'm running.

Thanks



--------------------------------------------------------------------------------

I want to make sure I understand

Team A, Team B, Team C
Team A, Team B, Team D
Team A, Team B, Team E
.
.
.
Team B, Team C, Team D
Team B, Team C, Team E

etc.......





--------------------------------------------------------------------------------

Correct Frank

In other words

Team A, B, C and C, B, A would be no good.

There are 4,960 combo's of the example YOU gave.

Another example, if say you bought a ticket with Team A, Team B and Team C, you would be the only person with that 3 team combination. (No 2 tickets would have the same combination)

--------------------------------------------------------------------------------



--------------------------------------------------------------------------------

Mets, this could be done with excel, but I'm not good enough at programming to figure it out.. All I have is a program that spits out permutations, whereas you're looking for combinations. You could post this question on the message boards at excelforumdotcom and someone there might be able to give you insight into how to go about it.

Below is code that Myrna Larson wrote.

Copy it into a module, then put a C into cell A1, 3 into cell A2, and Team
A, Team B, Team C, etc. into cells A3:A34.

Then run the macro "ListPermutations" (which also does combinations) and it
will create your list on a new worksheet.

HTH,
Bernie
MS Excel MVP


' Maybe, Myrna will post the entire functioning code module

'Since you asked, here it is. It is generic, i.e. it isn't written
specifically
' for a given population and set size, as yours it. It will do permutations
or
' combinations. It uses a recursive routine to generate the subsets, one
routine
' for combinations, a different one for permutations.

' To use it, you put the letter C or P (for combinations or permutations) in
a
' cell. The cell below that contains the number of items in a subset. The
Cells
' below are a list of the items that make up the population. They could be
' numbers, letters and symbols, or words, etc.

' You select the top cell, or the entire range and run the sub. The subsets
are
' written to a new sheet in the workbook.


Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet


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


Set Rng = Range(Range("A1"), Range("A1").End(xlDown))


PopSize = Rng.Cells.Count - 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.Count 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


With ActiveSheet.Range(Cells(1, 2), _
Cells(Range("A65536").End(xlUp).Row, 2))
.Formula = "=If(Countif($A$1:A1,A1)=1,""YES"","""")"
.Value = .Value
If Application.WorksheetFunction.CountBlank(.Cells) Then
If MsgBox("Remove duplicates?", vbYesNo, _
"Permutations and Combinations") = vbYes Then
.SpecialCells(xlBlanks).EntireRow.Delete
End If
End If
.EntireColumn.Delete
End With


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



"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Here's an easier version: with your team names in cells A1:A32, run this:

Sub EasierVersion()
Dim i As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
Range("B65536").End(xlUp)(2).Value = _
Cells(i, 1).Value & ", " & _
Cells(j, 1).Value & ", " & Cells(k, 1).Value
Next k
Next j
Next i

End Sub

HTH,
Bernie
MS Excel MVP


"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>

Below is code that Myrna Larson wrote.

Copy it into a module, then put a C into cell A1, 3 into cell A2, and Team
A, Team B, Team C, etc. into cells A3:A34.

Then run the macro "ListPermutations" (which also does combinations) and it
will create your list on a new worksheet.

HTH,
Bernie
MS Excel MVP


' Maybe, Myrna will post the entire functioning code module

'Since you asked, here it is. It is generic, i.e. it isn't written
specifically
' for a given population and set size, as yours it. It will do permutations
or
' combinations. It uses a recursive routine to generate the subsets, one
routine
' for combinations, a different one for permutations.

' To use it, you put the letter C or P (for combinations or permutations) in
a
' cell. The cell below that contains the number of items in a subset. The
Cells
' below are a list of the items that make up the population. They could be
' numbers, letters and symbols, or words, etc.

' You select the top cell, or the entire range and run the sub. The subsets
are
' written to a new sheet in the workbook.


Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet


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


Set Rng = Range(Range("A1"), Range("A1").End(xlDown))


PopSize = Rng.Cells.Count - 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.Count 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


With ActiveSheet.Range(Cells(1, 2), _
Cells(Range("A65536").End(xlUp).Row, 2))
.Formula = "=If(Countif($A$1:A1,A1)=1,""YES"","""")"
.Value = .Value
If Application.WorksheetFunction.CountBlank(.Cells) Then
If MsgBox("Remove duplicates?", vbYesNo, _
"Permutations and Combinations") = vbYes Then
.SpecialCells(xlBlanks).EntireRow.Delete
End If
End If
.EntireColumn.Delete
End With


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



"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Here's an easier version: with your team names in cells A1:A32, run this:

Sub EasierVersion()
Dim i As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
Range("B65536").End(xlUp)(2).Value = _
Cells(i, 1).Value & ", " & _
Cells(j, 1).Value & ", " & Cells(k, 1).Value
Next k
Next j
Next i

End Sub

HTH,
Bernie
MS Excel MVP


"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>

Below is code that Myrna Larson wrote.

Copy it into a module, then put a C into cell A1, 3 into cell A2, and Team
A, Team B, Team C, etc. into cells A3:A34.

Then run the macro "ListPermutations" (which also does combinations) and it
will create your list on a new worksheet.

HTH,
Bernie
MS Excel MVP


' Maybe, Myrna will post the entire functioning code module

'Since you asked, here it is. It is generic, i.e. it isn't written
specifically
' for a given population and set size, as yours it. It will do permutations
or
' combinations. It uses a recursive routine to generate the subsets, one
routine
' for combinations, a different one for permutations.

' To use it, you put the letter C or P (for combinations or permutations) in
a
' cell. The cell below that contains the number of items in a subset. The
Cells
' below are a list of the items that make up the population. They could be
' numbers, letters and symbols, or words, etc.

' You select the top cell, or the entire range and run the sub. The subsets
are
' written to a new sheet in the workbook.


Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet


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


Set Rng = Range(Range("A1"), Range("A1").End(xlDown))


PopSize = Rng.Cells.Count - 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.Count 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


With ActiveSheet.Range(Cells(1, 2), _
Cells(Range("A65536").End(xlUp).Row, 2))
.Formula = "=If(Countif($A$1:A1,A1)=1,""YES"","""")"
.Value = .Value
If Application.WorksheetFunction.CountBlank(.Cells) Then
If MsgBox("Remove duplicates?", vbYesNo, _
"Permutations and Combinations") = vbYes Then
.SpecialCells(xlBlanks).EntireRow.Delete
End If
End If
.EntireColumn.Delete
End With


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



"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Here's an easier version: with your team names in cells A1:A32, run this:

Sub EasierVersion()
Dim i As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
Range("B65536").End(xlUp)(2).Value = _
Cells(i, 1).Value & ", " & _
Cells(j, 1).Value & ", " & Cells(k, 1).Value
Next k
Next j
Next i

End Sub

HTH,
Bernie
MS Excel MVP


"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>

Here's an easier version: with your team names in cells A1:A32, run this:

Sub EasierVersion()
Dim i As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
Range("B65536").End(xlUp)(2).Value = _
Cells(i, 1).Value & ", " & _
Cells(j, 1).Value & ", " & Cells(k, 1).Value
Next k
Next j
Next i

End Sub

HTH,
Bernie
MS Excel MVP


"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Below is code that Myrna Larson wrote.

Copy it into a module, then put a C into cell A1, 3 into cell A2, and Team
A, Team B, Team C, etc. into cells A3:A34.

Then run the macro "ListPermutations" (which also does combinations) and it
will create your list on a new worksheet.

HTH,
Bernie
MS Excel MVP


' Maybe, Myrna will post the entire functioning code module

'Since you asked, here it is. It is generic, i.e. it isn't written
specifically
' for a given population and set size, as yours it. It will do permutations
or
' combinations. It uses a recursive routine to generate the subsets, one
routine
' for combinations, a different one for permutations.

' To use it, you put the letter C or P (for combinations or permutations) in
a
' cell. The cell below that contains the number of items in a subset. The
Cells
' below are a list of the items that make up the population. They could be
' numbers, letters and symbols, or words, etc.

' You select the top cell, or the entire range and run the sub. The subsets
are
' written to a new sheet in the workbook.


Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet


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


Set Rng = Range(Range("A1"), Range("A1").End(xlDown))


PopSize = Rng.Cells.Count - 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.Count 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


With ActiveSheet.Range(Cells(1, 2), _
Cells(Range("A65536").End(xlUp).Row, 2))
.Formula = "=If(Countif($A$1:A1,A1)=1,""YES"","""")"
.Value = .Value
If Application.WorksheetFunction.CountBlank(.Cells) Then
If MsgBox("Remove duplicates?", vbYesNo, _
"Permutations and Combinations") = vbYes Then
.SpecialCells(xlBlanks).EntireRow.Delete
End If
End If
.EntireColumn.Delete
End With


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



"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>

Here's an easier version: with your team names in cells A1:A32, run this:

Sub EasierVersion()
Dim i As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
Range("B65536").End(xlUp)(2).Value = _
Cells(i, 1).Value & ", " & _
Cells(j, 1).Value & ", " & Cells(k, 1).Value
Next k
Next j
Next i

End Sub

HTH,
Bernie
MS Excel MVP


"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Below is code that Myrna Larson wrote.

Copy it into a module, then put a C into cell A1, 3 into cell A2, and Team
A, Team B, Team C, etc. into cells A3:A34.

Then run the macro "ListPermutations" (which also does combinations) and it
will create your list on a new worksheet.

HTH,
Bernie
MS Excel MVP


' Maybe, Myrna will post the entire functioning code module

'Since you asked, here it is. It is generic, i.e. it isn't written
specifically
' for a given population and set size, as yours it. It will do permutations
or
' combinations. It uses a recursive routine to generate the subsets, one
routine
' for combinations, a different one for permutations.

' To use it, you put the letter C or P (for combinations or permutations) in
a
' cell. The cell below that contains the number of items in a subset. The
Cells
' below are a list of the items that make up the population. They could be
' numbers, letters and symbols, or words, etc.

' You select the top cell, or the entire range and run the sub. The subsets
are
' written to a new sheet in the workbook.


Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet


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


Set Rng = Range(Range("A1"), Range("A1").End(xlDown))


PopSize = Rng.Cells.Count - 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.Count 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


With ActiveSheet.Range(Cells(1, 2), _
Cells(Range("A65536").End(xlUp).Row, 2))
.Formula = "=If(Countif($A$1:A1,A1)=1,""YES"","""")"
.Value = .Value
If Application.WorksheetFunction.CountBlank(.Cells) Then
If MsgBox("Remove duplicates?", vbYesNo, _
"Permutations and Combinations") = vbYes Then
.SpecialCells(xlBlanks).EntireRow.Delete
End If
End If
.EntireColumn.Delete
End With


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



"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Below is code that Myrna Larson wrote.

Copy it into a module, then put a C into cell A1, 3 into cell A2, and Team
A, Team B, Team C, etc. into cells A3:A34.

Then run the macro "ListPermutations" (which also does combinations) and it
will create your list on a new worksheet.

HTH,
Bernie
MS Excel MVP


' Maybe, Myrna will post the entire functioning code module

'Since you asked, here it is. It is generic, i.e. it isn't written
specifically
' for a given population and set size, as yours it. It will do permutations
or
' combinations. It uses a recursive routine to generate the subsets, one
routine
' for combinations, a different one for permutations.

' To use it, you put the letter C or P (for combinations or permutations) in
a
' cell. The cell below that contains the number of items in a subset. The
Cells
' below are a list of the items that make up the population. They could be
' numbers, letters and symbols, or words, etc.

' You select the top cell, or the entire range and run the sub. The subsets
are
' written to a new sheet in the workbook.


Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet


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


Set Rng = Range(Range("A1"), Range("A1").End(xlDown))


PopSize = Rng.Cells.Count - 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.Count 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


With ActiveSheet.Range(Cells(1, 2), _
Cells(Range("A65536").End(xlUp).Row, 2))
.Formula = "=If(Countif($A$1:A1,A1)=1,""YES"","""")"
.Value = .Value
If Application.WorksheetFunction.CountBlank(.Cells) Then
If MsgBox("Remove duplicates?", vbYesNo, _
"Permutations and Combinations") = vbYes Then
.SpecialCells(xlBlanks).EntireRow.Delete
End If
End If
.EntireColumn.Delete
End With


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



"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>

Here's an easier version: with your team names in cells A1:A32, run this:

Sub EasierVersion()
Dim i As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
Range("B65536").End(xlUp)(2).Value = _
Cells(i, 1).Value & ", " & _
Cells(j, 1).Value & ", " & Cells(k, 1).Value
Next k
Next j
Next i

End Sub

HTH,
Bernie
MS Excel MVP


"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>

Here's an easier version: with your team names in cells A1:A32, run this:

Sub EasierVersion()
Dim i As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
Range("B65536").End(xlUp)(2).Value = _
Cells(i, 1).Value & ", " & _
Cells(j, 1).Value & ", " & Cells(k, 1).Value
Next k
Next j
Next i

End Sub

HTH,
Bernie
MS Excel MVP


"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Below is code that Myrna Larson wrote.

Copy it into a module, then put a C into cell A1, 3 into cell A2, and Team
A, Team B, Team C, etc. into cells A3:A34.

Then run the macro "ListPermutations" (which also does combinations) and it
will create your list on a new worksheet.

HTH,
Bernie
MS Excel MVP


' Maybe, Myrna will post the entire functioning code module

'Since you asked, here it is. It is generic, i.e. it isn't written
specifically
' for a given population and set size, as yours it. It will do permutations
or
' combinations. It uses a recursive routine to generate the subsets, one
routine
' for combinations, a different one for permutations.

' To use it, you put the letter C or P (for combinations or permutations) in
a
' cell. The cell below that contains the number of items in a subset. The
Cells
' below are a list of the items that make up the population. They could be
' numbers, letters and symbols, or words, etc.

' You select the top cell, or the entire range and run the sub. The subsets
are
' written to a new sheet in the workbook.


Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet


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


Set Rng = Range(Range("A1"), Range("A1").End(xlDown))


PopSize = Rng.Cells.Count - 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.Count 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


With ActiveSheet.Range(Cells(1, 2), _
Cells(Range("A65536").End(xlUp).Row, 2))
.Formula = "=If(Countif($A$1:A1,A1)=1,""YES"","""")"
.Value = .Value
If Application.WorksheetFunction.CountBlank(.Cells) Then
If MsgBox("Remove duplicates?", vbYesNo, _
"Permutations and Combinations") = vbYes Then
.SpecialCells(xlBlanks).EntireRow.Delete
End If
End If
.EntireColumn.Delete
End With


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



"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>

Here's an easier version: with your team names in cells A1:A32, run this:

Sub EasierVersion()
Dim i As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
Range("B65536").End(xlUp)(2).Value = _
Cells(i, 1).Value & ", " & _
Cells(j, 1).Value & ", " & Cells(k, 1).Value
Next k
Next j
Next i

End Sub

HTH,
Bernie
MS Excel MVP


"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Below is code that Myrna Larson wrote.

Copy it into a module, then put a C into cell A1, 3 into cell A2, and Team
A, Team B, Team C, etc. into cells A3:A34.

Then run the macro "ListPermutations" (which also does combinations) and it
will create your list on a new worksheet.

HTH,
Bernie
MS Excel MVP


' Maybe, Myrna will post the entire functioning code module

'Since you asked, here it is. It is generic, i.e. it isn't written
specifically
' for a given population and set size, as yours it. It will do permutations
or
' combinations. It uses a recursive routine to generate the subsets, one
routine
' for combinations, a different one for permutations.

' To use it, you put the letter C or P (for combinations or permutations) in
a
' cell. The cell below that contains the number of items in a subset. The
Cells
' below are a list of the items that make up the population. They could be
' numbers, letters and symbols, or words, etc.

' You select the top cell, or the entire range and run the sub. The subsets
are
' written to a new sheet in the workbook.


Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet


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


Set Rng = Range(Range("A1"), Range("A1").End(xlDown))


PopSize = Rng.Cells.Count - 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.Count 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


With ActiveSheet.Range(Cells(1, 2), _
Cells(Range("A65536").End(xlUp).Row, 2))
.Formula = "=If(Countif($A$1:A1,A1)=1,""YES"","""")"
.Value = .Value
If Application.WorksheetFunction.CountBlank(.Cells) Then
If MsgBox("Remove duplicates?", vbYesNo, _
"Permutations and Combinations") = vbYes Then
.SpecialCells(xlBlanks).EntireRow.Delete
End If
End If
.EntireColumn.Delete
End With


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



"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>

Here's an easier version: with your team names in cells A1:A32, run this:

Sub EasierVersion()
Dim i As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
Range("B65536").End(xlUp)(2).Value = _
Cells(i, 1).Value & ", " & _
Cells(j, 1).Value & ", " & Cells(k, 1).Value
Next k
Next j
Next i

End Sub

HTH,
Bernie
MS Excel MVP


"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Below is code that Myrna Larson wrote.

Copy it into a module, then put a C into cell A1, 3 into cell A2, and Team
A, Team B, Team C, etc. into cells A3:A34.

Then run the macro "ListPermutations" (which also does combinations) and it
will create your list on a new worksheet.

HTH,
Bernie
MS Excel MVP


' Maybe, Myrna will post the entire functioning code module

'Since you asked, here it is. It is generic, i.e. it isn't written
specifically
' for a given population and set size, as yours it. It will do permutations
or
' combinations. It uses a recursive routine to generate the subsets, one
routine
' for combinations, a different one for permutations.

' To use it, you put the letter C or P (for combinations or permutations) in
a
' cell. The cell below that contains the number of items in a subset. The
Cells
' below are a list of the items that make up the population. They could be
' numbers, letters and symbols, or words, etc.

' You select the top cell, or the entire range and run the sub. The subsets
are
' written to a new sheet in the workbook.


Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet


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


Set Rng = Range(Range("A1"), Range("A1").End(xlDown))


PopSize = Rng.Cells.Count - 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.Count 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


With ActiveSheet.Range(Cells(1, 2), _
Cells(Range("A65536").End(xlUp).Row, 2))
.Formula = "=If(Countif($A$1:A1,A1)=1,""YES"","""")"
.Value = .Value
If Application.WorksheetFunction.CountBlank(.Cells) Then
If MsgBox("Remove duplicates?", vbYesNo, _
"Permutations and Combinations") = vbYes Then
.SpecialCells(xlBlanks).EntireRow.Delete
End If
End If
.EntireColumn.Delete
End With


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



"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Here's an easier version: with your team names in cells A1:A32, run this:

Sub EasierVersion()
Dim i As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
Range("B65536").End(xlUp)(2).Value = _
Cells(i, 1).Value & ", " & _
Cells(j, 1).Value & ", " & Cells(k, 1).Value
Next k
Next j
Next i

End Sub

HTH,
Bernie
MS Excel MVP


"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>

Below is code that Myrna Larson wrote.

Copy it into a module, then put a C into cell A1, 3 into cell A2, and Team
A, Team B, Team C, etc. into cells A3:A34.

Then run the macro "ListPermutations" (which also does combinations) and it
will create your list on a new worksheet.

HTH,
Bernie
MS Excel MVP


' Maybe, Myrna will post the entire functioning code module

'Since you asked, here it is. It is generic, i.e. it isn't written
specifically
' for a given population and set size, as yours it. It will do permutations
or
' combinations. It uses a recursive routine to generate the subsets, one
routine
' for combinations, a different one for permutations.

' To use it, you put the letter C or P (for combinations or permutations) in
a
' cell. The cell below that contains the number of items in a subset. The
Cells
' below are a list of the items that make up the population. They could be
' numbers, letters and symbols, or words, etc.

' You select the top cell, or the entire range and run the sub. The subsets
are
' written to a new sheet in the workbook.


Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet


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


Set Rng = Range(Range("A1"), Range("A1").End(xlDown))


PopSize = Rng.Cells.Count - 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.Count 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


With ActiveSheet.Range(Cells(1, 2), _
Cells(Range("A65536").End(xlUp).Row, 2))
.Formula = "=If(Countif($A$1:A1,A1)=1,""YES"","""")"
.Value = .Value
If Application.WorksheetFunction.CountBlank(.Cells) Then
If MsgBox("Remove duplicates?", vbYesNo, _
"Permutations and Combinations") = vbYes Then
.SpecialCells(xlBlanks).EntireRow.Delete
End If
End If
.EntireColumn.Delete
End With


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



"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Below is code that Myrna Larson wrote.

Copy it into a module, then put a C into cell A1, 3 into cell A2, and Team
A, Team B, Team C, etc. into cells A3:A34.

Then run the macro "ListPermutations" (which also does combinations) and it
will create your list on a new worksheet.

HTH,
Bernie
MS Excel MVP


' Maybe, Myrna will post the entire functioning code module

'Since you asked, here it is. It is generic, i.e. it isn't written
specifically
' for a given population and set size, as yours it. It will do permutations
or
' combinations. It uses a recursive routine to generate the subsets, one
routine
' for combinations, a different one for permutations.

' To use it, you put the letter C or P (for combinations or permutations) in
a
' cell. The cell below that contains the number of items in a subset. The
Cells
' below are a list of the items that make up the population. They could be
' numbers, letters and symbols, or words, etc.

' You select the top cell, or the entire range and run the sub. The subsets
are
' written to a new sheet in the workbook.


Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet


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


Set Rng = Range(Range("A1"), Range("A1").End(xlDown))


PopSize = Rng.Cells.Count - 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.Count 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


With ActiveSheet.Range(Cells(1, 2), _
Cells(Range("A65536").End(xlUp).Row, 2))
.Formula = "=If(Countif($A$1:A1,A1)=1,""YES"","""")"
.Value = .Value
If Application.WorksheetFunction.CountBlank(.Cells) Then
If MsgBox("Remove duplicates?", vbYesNo, _
"Permutations and Combinations") = vbYes Then
.SpecialCells(xlBlanks).EntireRow.Delete
End If
End If
.EntireColumn.Delete
End With


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



"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Here's an easier version: with your team names in cells A1:A32, run this:

Sub EasierVersion()
Dim i As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
Range("B65536").End(xlUp)(2).Value = _
Cells(i, 1).Value & ", " & _
Cells(j, 1).Value & ", " & Cells(k, 1).Value
Next k
Next j
Next i

End Sub

HTH,
Bernie
MS Excel MVP


"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>

Here's an easier version: with your team names in cells A1:A32, run this:

Sub EasierVersion()
Dim i As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
Range("B65536").End(xlUp)(2).Value = _
Cells(i, 1).Value & ", " & _
Cells(j, 1).Value & ", " & Cells(k, 1).Value
Next k
Next j
Next i

End Sub

HTH,
Bernie
MS Excel MVP


"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>

Below is code that Myrna Larson wrote.

Copy it into a module, then put a C into cell A1, 3 into cell A2, and Team
A, Team B, Team C, etc. into cells A3:A34.

Then run the macro "ListPermutations" (which also does combinations) and it
will create your list on a new worksheet.

HTH,
Bernie
MS Excel MVP


' Maybe, Myrna will post the entire functioning code module

'Since you asked, here it is. It is generic, i.e. it isn't written
specifically
' for a given population and set size, as yours it. It will do permutations
or
' combinations. It uses a recursive routine to generate the subsets, one
routine
' for combinations, a different one for permutations.

' To use it, you put the letter C or P (for combinations or permutations) in
a
' cell. The cell below that contains the number of items in a subset. The
Cells
' below are a list of the items that make up the population. They could be
' numbers, letters and symbols, or words, etc.

' You select the top cell, or the entire range and run the sub. The subsets
are
' written to a new sheet in the workbook.


Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet


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


Set Rng = Range(Range("A1"), Range("A1").End(xlDown))


PopSize = Rng.Cells.Count - 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.Count 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


With ActiveSheet.Range(Cells(1, 2), _
Cells(Range("A65536").End(xlUp).Row, 2))
.Formula = "=If(Countif($A$1:A1,A1)=1,""YES"","""")"
.Value = .Value
If Application.WorksheetFunction.CountBlank(.Cells) Then
If MsgBox("Remove duplicates?", vbYesNo, _
"Permutations and Combinations") = vbYes Then
.SpecialCells(xlBlanks).EntireRow.Delete
End If
End If
.EntireColumn.Delete
End With


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



"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Below is code that Myrna Larson wrote.

Copy it into a module, then put a C into cell A1, 3 into cell A2, and Team
A, Team B, Team C, etc. into cells A3:A34.

Then run the macro "ListPermutations" (which also does combinations) and it
will create your list on a new worksheet.

HTH,
Bernie
MS Excel MVP


' Maybe, Myrna will post the entire functioning code module

'Since you asked, here it is. It is generic, i.e. it isn't written
specifically
' for a given population and set size, as yours it. It will do permutations
or
' combinations. It uses a recursive routine to generate the subsets, one
routine
' for combinations, a different one for permutations.

' To use it, you put the letter C or P (for combinations or permutations) in
a
' cell. The cell below that contains the number of items in a subset. The
Cells
' below are a list of the items that make up the population. They could be
' numbers, letters and symbols, or words, etc.

' You select the top cell, or the entire range and run the sub. The subsets
are
' written to a new sheet in the workbook.


Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet


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


Set Rng = Range(Range("A1"), Range("A1").End(xlDown))


PopSize = Rng.Cells.Count - 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.Count 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


With ActiveSheet.Range(Cells(1, 2), _
Cells(Range("A65536").End(xlUp).Row, 2))
.Formula = "=If(Countif($A$1:A1,A1)=1,""YES"","""")"
.Value = .Value
If Application.WorksheetFunction.CountBlank(.Cells) Then
If MsgBox("Remove duplicates?", vbYesNo, _
"Permutations and Combinations") = vbYes Then
.SpecialCells(xlBlanks).EntireRow.Delete
End If
End If
.EntireColumn.Delete
End With


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



"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Here's an easier version: with your team names in cells A1:A32, run this:

Sub EasierVersion()
Dim i As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
Range("B65536").End(xlUp)(2).Value = _
Cells(i, 1).Value & ", " & _
Cells(j, 1).Value & ", " & Cells(k, 1).Value
Next k
Next j
Next i

End Sub

HTH,
Bernie
MS Excel MVP


"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>

Below is code that Myrna Larson wrote.

Copy it into a module, then put a C into cell A1, 3 into cell A2, and Team
A, Team B, Team C, etc. into cells A3:A34.

Then run the macro "ListPermutations" (which also does combinations) and it
will create your list on a new worksheet.

HTH,
Bernie
MS Excel MVP


' Maybe, Myrna will post the entire functioning code module

'Since you asked, here it is. It is generic, i.e. it isn't written
specifically
' for a given population and set size, as yours it. It will do permutations
or
' combinations. It uses a recursive routine to generate the subsets, one
routine
' for combinations, a different one for permutations.

' To use it, you put the letter C or P (for combinations or permutations) in
a
' cell. The cell below that contains the number of items in a subset. The
Cells
' below are a list of the items that make up the population. They could be
' numbers, letters and symbols, or words, etc.

' You select the top cell, or the entire range and run the sub. The subsets
are
' written to a new sheet in the workbook.


Option Explicit

Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet


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


Set Rng = Range(Range("A1"), Range("A1").End(xlDown))


PopSize = Rng.Cells.Count - 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.Count 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


With ActiveSheet.Range(Cells(1, 2), _
Cells(Range("A65536").End(xlUp).Row, 2))
.Formula = "=If(Countif($A$1:A1,A1)=1,""YES"","""")"
.Value = .Value
If Application.WorksheetFunction.CountBlank(.Cells) Then
If MsgBox("Remove duplicates?", vbYesNo, _
"Permutations and Combinations") = vbYes Then
.SpecialCells(xlBlanks).EntireRow.Delete
End If
End If
.EntireColumn.Delete
End With


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



"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

Here's an easier version: with your team names in cells A1:A32, run this:

Sub EasierVersion()
Dim i As Integer
Dim j As Integer
Dim k As Integer

For i = 1 To 30
For j = i + 1 To 31
For k = j + 1 To 32
Range("B65536").End(xlUp)(2).Value = _
Cells(i, 1).Value & ", " & _
Cells(j, 1).Value & ", " & Cells(k, 1).Value
Next k
Next j
Next i

End Sub

HTH,
Bernie
MS Excel MVP


"Bluesters" <[email protected]> wrote
in message news:[email protected]...
>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>

You can do this without a macro.
In cells A1 to A3 enter the numbers 1 to 3.
In cell A2:
=IF(AND(B1=31,C1=32),A1+1,A1)
In cell B2:
=IF(AND($C1<32,$B1<=31),$B1,0)+IF(AND(C1=32,B1<31),B1+1,0)+IF(AND(B1=31,C1=32),A2+1,0)
In cell C2:
=IF(C1<32,C1+1,B2+1)
Copy cells A2:C2 to A2:C4960.

"Bluesters" wrote:

>
> Math Question for football pool
>
> --------------------------------------------------------------------------------
>
> Does anyone know where I can obtain software that would enable me to
> print out all 4,960 3 team football combinations using the 32 NFL teams
> (Order does not matter), it would be used for a pool I'm running.
>
> Thanks
>
>
>
> --------------------------------------------------------------------------------
>
> I want to make sure I understand
>
> Team A, Team B, Team C
> Team A, Team B, Team D
> Team A, Team B, Team E
>