VBA code to list all permutation of N distinct objects of size r without repetition

[Chyke_mxl]

Hi,
Can someone help me edit this code to list all permutation of n distinct object of size r without repetition. For example, if i have three letters, {A,B,C} to form arrangement of size two, i will get: {A,B}, {A,C}, {B,A}, {B,C}, {C,A} and {C,B}. {A,A}, {B,B} and {C,C} are NOT included..
The vba code is pasted below

Thank you.

Sub Permutations()
Dim rRng As Range, p As Integer
Dim vElements, lRow As Long, vresult As Variant

Set rRng = Range("A1", Range("A1").End(xlDown)) ' The set of numbers
p = Range("B1").Value ' How many are picked

vElements = Application.Index(Application.Transpose(rRng), 1, 0)
ReDim vresult(1 To p)
Columns("C").Resize(, p + 1).Clear
Call PermutationsNP(vElements, p, vresult, lRow, 1, 1)
End Sub

Sub PermutationsNP(vElements As Variant, p As Integer, vresult As Variant, lRow As Long, iElement As Integer, iIndex As Integer)
Dim i As Integer

For i = 1 To UBound(vElements)
vresult(iIndex) = vElements(i)
If iIndex = p Then
lRow = lRow + 1
Range("C" & lRow).Resize(, p) = vresult
Else
Call PermutationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1)
End If
Next i
End Sub

 

[lrobbo314]

How about this?

Book1
	A
1	A,B
2	A,C
3	B,A
4	B,C
5	C,A
6	C,B
Sheet1

Sub CREATECOMBO()
Dim AL As Object:       Set AL = CreateObject("System.Collections.ArrayList")
Dim Grp As Integer:     Grp = 2
Dim Tot As Integer:     Tot = 3

Main AL, Grp, Tot

Range("A1").Resize(AL.Count).Value = Application.Transpose(AL.toArray)
End Sub

Sub Main(AL As Object, Grp As Integer, Tot As Integer)
Dim AR(1 To 3) As Variant

AR(1) = "A"
AR(2) = "B"
AR(3) = "C"

Combo AR, Grp, 1, 0, "", AL
End Sub

Sub Combo(AR() As Variant, Grp As Integer, IDX As Integer, Depth As Integer, Buffer As String, AL As Object)
Dim Prefix As String
Dim b As Boolean: b = True

For i = 1 To UBound(AR)
    If Buffer = vbNullString Then
        Prefix = AR(i)
    Else
        If Buffer <> AR(i) Then
            Prefix = Join(Array(Buffer, AR(i)), ",")
            b = True
        Else
            b = False
        End If
    End If
    If Depth + 1 = Grp Then
        If b Then AL.Add Prefix
    Else
        Combo AR, Grp, i + 1, Depth + 1, Prefix, AL
    End If
Next i
End Sub

 

[Chyke_mxl]

How about this?

Book1
	A
1	A,B
2	A,C
3	B,A
4	B,C
5	C,A
6	C,B
Sheet1

Sub CREATECOMBO()
Dim AL As Object:       Set AL = CreateObject("System.Collections.ArrayList")
Dim Grp As Integer:     Grp = 2
Dim Tot As Integer:     Tot = 3

Main AL, Grp, Tot

Range("A1").Resize(AL.Count).Value = Application.Transpose(AL.toArray)
End Sub

Sub Main(AL As Object, Grp As Integer, Tot As Integer)
Dim AR(1 To 3) As Variant

AR(1) = "A"
AR(2) = "B"
AR(3) = "C"

Combo AR, Grp, 1, 0, "", AL
End Sub

Sub Combo(AR() As Variant, Grp As Integer, IDX As Integer, Depth As Integer, Buffer As String, AL As Object)
Dim Prefix As String
Dim b As Boolean: b = True

For i = 1 To UBound(AR)
    If Buffer = vbNullString Then
        Prefix = AR(i)
    Else
        If Buffer <> AR(i) Then
            Prefix = Join(Array(Buffer, AR(i)), ",")
            b = True
        Else
            b = False
        End If
    End If
    If Depth + 1 = Grp Then
        If b Then AL.Add Prefix
    Else
        Combo AR, Grp, i + 1, Depth + 1, Prefix, AL
    End If
Next i
End Sub

Thanks, but i would've loved if the output is in the same format as the one pasted in the question above.

 

[lrobbo314]

Like this?

Book1
	A
1	{A,B}
2	{A,C}
3	{B,A}
4	{B,C}
5	{C,A}
6	{C,B}
Sheet1

Sub CREATECOMBO()
Dim AL As Object:       Set AL = CreateObject("System.Collections.ArrayList")
Dim Grp As Integer:     Grp = 2
Dim Tot As Integer:     Tot = 3

Main AL, Grp, Tot

Range("A1").Resize(AL.Count).Value = Application.Transpose(AL.toArray)
End Sub

Sub Main(AL As Object, Grp As Integer, Tot As Integer)
Dim AR(1 To 3) As Variant:        'AR = Array("A", "B", "C") 'AR = Evaluate("TRANSPOSE(INDEX(ROW(1:" & Tot & "),))")
AR(1) = "A"
AR(2) = "B"
AR(3) = "C"
Combo AR, Grp, 1, 0, "", AL
End Sub

Sub Combo(AR() As Variant, Grp As Integer, IDX As Integer, Depth As Integer, Buffer As String, AL As Object)
Dim Prefix As String
Dim b As Boolean: b = True

For i = 1 To UBound(AR)
    If Buffer = vbNullString Then
        Prefix = AR(i)
    Else
        If Buffer <> AR(i) Then
            Prefix = Join(Array(Buffer, AR(i)), ",")
            b = True
        Else
            b = False
        End If
    End If
    If Depth + 1 = Grp Then
        If b Then AL.Add "{" & Prefix & "}"
    Else
        Combo AR, Grp, i + 1, Depth + 1, Prefix, AL
    End If
Next i
End Sub

 

[Eric W]

Another option:

Sub Permutations()
Dim dic As Object, res As Object, d As Variant, i As Long, p As Long

    Set dic = CreateObject("Scripting.Dictionary")
    Set res = CreateObject("Scripting.Dictionary")
   
    d = Range("A1", Range("A1").End(xlDown)).Value
    For i = 1 To UBound(d)
        dic.Add d(i, 1), 0
    Next i
    p = Range("B1").Value
   
    Call PermutationsNP(dic, res, p, 0, "")
   
    Range("C1").Resize(res.Count).Value = WorksheetFunction.Transpose(res.items)
    Range("C:C").TextToColumns DataType:=xlDelimited, OtherChar:="|"

End Sub

Sub PermutationsNP(ByVal dic, ByRef res, ByVal maxdepth, ByVal depth, ByVal soln)
Dim x As Variant

    If depth = maxdepth Then
        res.Add res.Count, soln
        Exit Sub
    End If
   
    For Each x In dic
        If dic(x) = 0 Then
            dic(x) = 1
            Call PermutationsNP(dic, res, maxdepth, depth + 1, soln & x & "|")
            dic(x) = 0
        End If
    Next x
       
End Sub

 

[Chyke_mxl]

Another option:

Sub Permutations()
Dim dic As Object, res As Object, d As Variant, i As Long, p As Long

    Set dic = CreateObject("Scripting.Dictionary")
    Set res = CreateObject("Scripting.Dictionary")
  
    d = Range("A1", Range("A1").End(xlDown)).Value
    For i = 1 To UBound(d)
        dic.Add d(i, 1), 0
    Next i
    p = Range("B1").Value
  
    Call PermutationsNP(dic, res, p, 0, "")
  
    Range("C1").Resize(res.Count).Value = WorksheetFunction.Transpose(res.items)
    Range("C:C").TextToColumns DataType:=xlDelimited, OtherChar:="|"

End Sub

Sub PermutationsNP(ByVal dic, ByRef res, ByVal maxdepth, ByVal depth, ByVal soln)
Dim x As Variant

    If depth = maxdepth Then
        res.Add res.Count, soln
        Exit Sub
    End If
  
    For Each x In dic
        If dic(x) = 0 Then
            dic(x) = 1
            Call PermutationsNP(dic, res, maxdepth, depth + 1, soln & x & "|")
            dic(x) = 0
        End If
    Next x
      
End Sub

Sir,

Thank you very much for your help. I am grateful.

But I would like the results to be entered in individual cell this layout: C1 D1 E1…e.tc, and then down the rows.

If I run the macro more than once in the same sheet, the previous outcome should be completely erased or replaced by the current results.

Cheers

Book1
	B
1	2
Sheet1

 

[Chyke_mxl]

Sir,

Thank you very much for your help. I am grateful.

But I would like the results to be entered in individual cell this layout: C1 D1 E1…e.tc, and then down the rows.

If I run the macro more than once in the same sheet, the previous outcome should be completely erased or replaced by the current results.

Cheers

Book1
	A	B	C	D
1	A	2	A	B
2	B		A	C
3	C		A	D
4	D		B	A
5			B	C
6			B	D
7			C	A
8			C	B
9			C	D
10			D	A
11			D	B
12			D	C
Sheet1

 

[Chyke_mxl]

Another option:

Sub Permutations()
Dim dic As Object, res As Object, d As Variant, i As Long, p As Long

    Set dic = CreateObject("Scripting.Dictionary")
    Set res = CreateObject("Scripting.Dictionary")
  
    d = Range("A1", Range("A1").End(xlDown)).Value
    For i = 1 To UBound(d)
        dic.Add d(i, 1), 0
    Next i
    p = Range("B1").Value
  
    Call PermutationsNP(dic, res, p, 0, "")
  
    Range("C1").Resize(res.Count).Value = WorksheetFunction.Transpose(res.items)
    Range("C:C").TextToColumns DataType:=xlDelimited, OtherChar:="|"

End Sub

Sub PermutationsNP(ByVal dic, ByRef res, ByVal maxdepth, ByVal depth, ByVal soln)
Dim x As Variant

    If depth = maxdepth Then
        res.Add res.Count, soln
        Exit Sub
    End If
  
    For Each x In dic
        If dic(x) = 0 Then
            dic(x) = 1
            Call PermutationsNP(dic, res, maxdepth, depth + 1, soln & x & "|")
            dic(x) = 0
        End If
    Next x
      
End Sub

Sir,

Thank you very much for your help. I am grateful.

But I would like the results to be entered in individual cell this layout: C1 D1 E1…e.tc, and then down the rows.

If I run the macro more than once in the same sheet, the previous outcome should be completely erased or replaced by the current results.

Cheers

Book1
	A	B	C	D
1	A	2	A	B
2	B		A	C
3	C		A	D
4	D		B	A
5			B	C
6			B	D
7			C	A
8			C	B
9			C	D
10			D	A
11			D	B
12			D	C
Sheet1

 

[Eric W]

But I would like the results to be entered in individual cell this layout: C1 D1 E1…e.tc, and then down the rows.

It already does that.

If I run the macro more than once in the same sheet, the previous outcome should be completely erased or replaced by the current results.

Just add this line:

Range("C:ZZ").ClearContents

in the Permutations sub, just before Call PermutationsNP.

 

[Chyke_mxl]

It already does that.


Just add this line:

Range("C:ZZ").ClearContents

in the Permutations sub, just before Call PermutationsNP.

Sir,

I am still stocked with the problem.

Thanks for your anticipated help.

Book1
	A	B	C
1	A	2	A|B|
2	B		A|C|
3	C		A|D|
4	D		B|A|
5			B|C|
6			B|D|
7			C|A|
8			C|B|
9			C|D|
10			D|A|
11			D|B|
12			D|C|
13
Sheet1