Code for Permutations & Combinations:


Option Explicit

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

Sub ListPermutations()

' 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.


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 = Selection.Columns(1).Cells
If rng.Cells.Count = 1 Then
Set rng = Range(rng, rng.End(xlDown))
End If

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

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


"Dave" wrote:

Hi,

In the UK lottery of 49 numbers 6 numbers makes a line. Our lottery
syndicate would like to enter every possible combinattion of 9 numbers (or
possibly 10). It's easy to work out that any 6 from 9 is 84 combinations ( 6
from 10 = 210) but it's much harder to work out what those combinations are.
At least it is if you have to guarantee accuracy because potentially a lot of
money rides on it.

So, the question is if i enter the 9 numbers in Excel can it work out and
list the 84 combinations?

D