Vba to list all possible permutations

[Gordonik]

Based on the sample data set. I am looking for a macro to return all possible permutations with repetition (order matters).
Let this code be universal (not only 3 but cover N unique arguments in a data set)
Let's this macro to do it in a new sheet and list an output in columns.
Google shows plenty of examples for string but not ranges.
There are a couple also where custom function is used but I do not want to use any Excel formula. Just run the code and get results.

Someone ready for this?

 

[Worf]

Maybe this:

' PGC Set 2007
' Calculates and writes the Combinations / Permutations with/without repetition
' vElements - Array with the set elements (1 to n)
' p - number of elements in 1 combination/permutation
' bComb - True: Combinations, False: Permutations
' bRepet - True: with repetition, False: without repetition
' vResult - Array to hold 1 permutation/combination (1 to p)
' lRow - row number. the next combination/permutation is written in lRow+1
' vResultAll - Array to hold all the permutations/combinations (1 to Total, 1 to p)
' iElement - order of the element to process in case of combination
' iIndex - position of the next element in the combination/permutation
' Sub CombPerm() deals with the input / output
' Sub CombPermNP() generates the combinations / permutations


Sub CombPerm()
Dim rRng As Range, p%, vElements, vResult As Variant, vResultAll, lTotal&
Dim lRow As Long, bComb As Boolean, bRepet As Boolean
' Get the inputs and clear the result range (you may adjust for other locations)
Set rRng = Range("B5", [B5].End(xlDown)) ' The set of numbers
p = [B1] ' How many are picked
bComb = [B2]
bRepet = [B3]
Columns("D").Resize(, p + 1).Clear
' Error
If (Not bRepet) And (rRng.count < p) Then
    MsgBox "With no repetition the number of elements of the set must be bigger or equal to p"
    Exit Sub
End If
' Set up the arrays for the set elements and the result
vElements = Application.Index(Application.Transpose(rRng), 1, 0)
With Application.WorksheetFunction
    If bComb = True Then
            lTotal = .Combin(rRng.count + IIf(bRepet, p - 1, 0), p)
    Else
        If bRepet = False Then lTotal = .Permut(rRng.count, p) Else lTotal = rRng.count ^ p
    End If
End With
ReDim vResult(1 To p)
ReDim vResultAll(1 To lTotal, 1 To p)
' Calculate the Combinations / Permutations
CombPermNP vElements, p, bComb, bRepet, vResult, lRow, vResultAll, 1, 1
[D1].Resize(lTotal, p).Value = vResultAll  'you may adjust for other location
End Sub
 
Sub CombPermNP(ByVal vElements As Variant, ByVal p%, ByVal bComb As Boolean, ByVal bRepet As Boolean, _
ByVal vResult As Variant, ByRef lRow As Long, ByRef vResultAll As Variant, ByVal iElement%, ByVal iIndex%)
Dim i As Integer, j As Integer, bSkip As Boolean
For i = IIf(bComb, iElement, 1) To UBound(vElements)
    bSkip = False
    ' in case of permutation without repetition makes sure the element is not yet used
    If (Not bComb) And Not bRepet Then
        For j = 1 To p
            If vElements(i) = vResult(j) And Not IsEmpty(vResult(j)) Then
                bSkip = True
                Exit For
            End If
        Next
    End If
     If Not bSkip Then
        vResult(iIndex) = vElements(i)
        If iIndex = p Then
            lRow = lRow + 1
            For j = 1 To p
                vResultAll(lRow, j) = vResult(j)
            Next j
        Else
            Call CombPermNP(vElements, p, bComb, bRepet, vResult, lRow, vResultAll, i + IIf(bComb And bRepet, 0, 1), iIndex + 1)
        End If
    End If
Next i
End Sub
' /////////////////////////////////

 

[Gordonik]

Worf. Thank U very much. Looks promising.
But I do not know why get the "Out of memory error"

in the line:

ReDim vResultAll(1 To lTotal, 1 To p)

I have tested it with p=9 and p=4 and always get this error
Do U know how to fix it?

 

[hiker95]

Gordonik,

See reply #2 at the next link, to get you started in the right direction:

http://www.mrexcel.com/forum/excel-questions/672274-combination-permutation-excel-add.html

 

[hiker95]

Gordonik,

With your sample raw data in Sheet1:

Excel 2007
	A
1	P
2	6
3	1
4	1
5	2
6	2
7	2
8	3
9
Sheet1

And, after the macro on a new worksheet (not all rows are shown for brevity):

Excel 2007
	A
1	112223
2	112232
3	112223
4	112232
5	112322
6	112322
7	112223
8	112232
9	112223
10	112232
710	322121
711	322112
712	322121
713	322211
714	322211
715	322112
716	322121
717	322112
718	322121
719	322211
720	322211
721
Sheet2

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

'*******************************************************************************
' Myrna Larson, July 25, 2000, Microsoft.Public.Excel.Misc
' http://www.mydatabasesupport.com/forums/spreadsheets/250560-combinations.html
'
'
' Following is a macro based solution form Myrna Larson (Microsoft MVP) on permutation and combinations
' 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)
'*******************************************************************************


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


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
   
   '****************************************
   ' Excel 2003
   If n > Cells.Count Then GoTo DataError
   
   'Excel 2007
   '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
   
   '********** Removes the ", " from the output **********
   Application.DisplayAlerts = False
   Columns("A:A").Replace What:=", ", Replacement:="", LookAt:=xlPart, _
       SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
       ReplaceFormat:=False
   Application.DisplayAlerts = True
   
   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 Long, 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)
       
       '************************************************************
       'With comma space
       sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
       'Without comma space
       '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

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ListPermutationsOrCombinations macro.

 

[Gordonik]

Thanks Guys.

@ Worf. On the beginning please ignore my post 3#. I made more test and the code you provided works fine.
It works but it does not really calculating permutations but variations. Below is a comparison.

In fact I need Permutation with / without repetition computed this way:

Permutations - Variations - Combinations

@ hiker 95 ​I will test you suggestion soon

 

[Gordonik]

@ hiker 95 ​

I have tested your suggestion and got this:

Data are where it should be. When click "ok" nothing happens

 

[hiker95]

Gordonik,

1. Is your raw data in worksheet Sheet1?

2. What version of Excel, and, Windows are you using?

3. Are you using a PC or a Mac?

 

[Gordonik]

hiker95,
I am using Sheet1, Excel 2013, Windows 7, PC
The issue is here:

 

[hiker95]

Gordonik,

You can see by the screenshots in my reply #5, that the macro does work correctly.

Can I see your actual raw data workbook?

You can post your workbook/worksheets to the following free site (sensitive data changed), mark the workbook for sharing, and, provide us with a link to your workbook:

https://dropbox.com


If you are not able to provide your raw data workbook, then:

Click on the Reply to Thread button, and just put the word BUMP in the thread. Then, click on the Post Quick Reply button, and someone else will assist you.