CODE FOR PERMUTATIONS & COMBINATIONS

Any valid code for Excel 2010 available for:

1. Listing all the possible Permutations & Combinations;
2. Of relevant/selected cells;
3. FROM a specific minimum size of items;
4. TO a maximum size of items?

For example:
With the data being simply five cells as:
A B C D E

Minimum Size being:
2

Maximum Size being
3

Result of PERMUTATIONS resulting to be:

A B
A C
A D
A E
B A
B C
B D
B E
C A
C B
C D
C E
D A
D B
D C
D E
E A
E B
E C
E D
A B C
A B D
A B E
A C B
A C D
A C E
A D B
A D C
A D E
A E B
A E C
A E D
B A C
B A D
B A E
B C A
B C D
B C E
B D A
B D C
B D E
B E A
B E C
B E D
C A B
C A D
C A E
C B A
C B D
C B E
C D A
C D B
C D E
C E A
C E B
C E D
D A B
D A C
D A E
D B A
D B C
D B E
D C A
D C B
D C E
D E A
D E B
D E C
E A B
E A C
E A D
E B A
E B C
E B D
E C A
E C B
E C D
E D A
E D B
E D C

And,

Result of COMBINATIONS resulting to be:

A B
A C
A D
A E
B C
B D
B E
C D
C E
D E
A B C
A B D
A B E
A C D
A C E
A D E
B C D
B C E
B D E
C D E

Thanx in advance!
 

Question Info


Last updated November 21, 2018 Views 5,574 Applies to:
Answer
Answer

Hi,

 

The code below was written by Myrna Larson and it does what you want but not in a single pass. paste the lot into a general midule and then on the worksheet enter the following

 

A1= C
A2 = 2
A3= A

A4=B

ETC

 

Carry on filling down from A3 as far as you need.

 

Now IMPORTANT select A1 and run the code. In this case it will add a new sheet with the combinations of 2 from n

 

Change A1 to P and you get permutations and change A2 to change the number to combine/permutate

 

 

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

Sub ListPermutations()
  Dim Rng As Range
  Dim PopSize As Integer
  Dim SetSize As Integer
  Dim Which As String
  Dim N As Double
  Const BufferSize As Long = 4096
  Set Rng = Selection.Columns(1).Cells
  If Rng.Cells.Count = 1 Then
    Set Rng = Range(Rng, Rng.End(xlDown))
  End If
  PopSize = Rng.Cells.CountLarge - 2
  If PopSize < 2 Then GoTo DataError
  SetSize = Rng.Cells(2).Value
  If SetSize > PopSize Then GoTo DataError
  Which = UCase$(Rng.Cells(1).Value)
  Select Case Which
  Case "C"
    N = Application.WorksheetFunction.Combin(PopSize, SetSize)
  Case "P"
    N = Application.WorksheetFunction.Permut(PopSize, SetSize)
  Case Else
    GoTo DataError
  End Select
  If N > Cells.CountLarge Then GoTo DataError
  Application.ScreenUpdating = False
  Set Results = Worksheets.Add
  vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
  ReDim Buffer(1 To BufferSize) As String
  BufferPtr = 0
  If Which = "C" Then
    AddCombination PopSize, SetSize
  Else
    AddPermutation PopSize, SetSize
  End If
  vAllItems = 0
  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

If this response answers your question then please mark as answer.

Mike H

1 person was helped by this reply

·

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.

Answer
Answer
OK!!!
So it was A1 that I had not been selecting!
Thanx for the excellent clarification buddy!


Hi,

 

Your welcome and thanks for the feedback

 

Also most versions of this code you will find on the web will fail with an overflow error in E2007 and E2010.

 

It was originally written for versions of Excel prior to E2007 and in those versions the lines (2 of them)

 

If N > Cells.Count Then GoTo DataError

are fine because there are less than  2147483647 cells on a worksheet in those versions of Excel

 

In E2007 and later the VB statement COUNTLARGE was added and the 2 lines in the code need to be changed as below to handle the 17179869184 cells on those worksheets

 

If N > Cells.CountLarge Then GoTo DataError

 

In the code I posted I simply changed those lines but to do it properly then you should do something along the lines of this pseudo code.

 

If application.version >= excel 2007 then

 

use countlarge

 

else

 

use count

 

end if

If this response answers your question then please mark as answer.

Mike H

Did this solve your problem?

Sorry this didn't help.

Great! Thanks for marking this as the answer.

How satisfied are you with this reply?

Thanks for your feedback, it helps us improve the site.

How satisfied are you with this response?

Thanks for your feedback.