1. It allows Combinations or Permutations.

2. The macro handles numbers, text strings, words (e.g. names of people) or symbols.

3. The combinations are written to a new sheet.

**(This needs to be changed. I want the result into new workbook)**

4. Results are returned almost instantaneously.

Setup:

In sheet1:

Cell A1, put “C” (Combinations) or “P” (Permutations).

Cell A2, put the number of items in the subset – in my case it’s 3.

Cells A3 down, your list. - in my case (numbers from 1-5)

My question is:

================

What changes do I need to make to this VBA code to get the result in a new workbook instead of a new sheet.

Maxi

====

CODE:

Option Explicit

Dim vAllItems As Variant

Dim Buffer() As String

Dim BufferPtr As Long

Dim Results As Worksheet

'

' Myrna Larson, July 25, 2000, Microsoft.Public.Excel.Misc

Sub ListPermutationsOrCombinations()

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

Worksheets("Sheet1").Range("A1").Select

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