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

 

[Eric W]

The last line in the Permutations macro:

Range("C:C").TextToColumns DataType:=xlDelimited, OtherChar:="|"

is supposed to split those into separate columns. Is that line still there? If so, do you get any errors when it runs? Try putting a breakpoint on it to see what happens. You can try selecting the C column, start the macro recorder, and use the Text to Columns tool on the Data tab to see what VBA it generates. But that works fine for me, I don't know why it's not for you.

 

[Chyke_mxl]

The last line in the Permutations macro:

Range("C:C").TextToColumns DataType:=xlDelimited, OtherChar:="|"

is supposed to split those into separate columns. Is that line still there? If so, do you get any errors when it runs? Try putting a breakpoint on it to see what happens. You can try selecting the C column, start the macro recorder, and use the Text to Columns tool on the Data tab to see what VBA it generates. But that works fine for me, I don't know why it's not for you.

Ok Sir,

but this is my first-time learning or using VBA code in MS Excel. I will try editing the code as you 've said. If you can edit it for me that will be fine too.

Thanks for your assistance,

Cheers

 

[Eric W]

You shouldn't have to edit the code, it should work as is. I'm trying to figure out why the TextToColumns line didn't work. If you can't figure it out either, then you can try this version:

Sub Permutations()
Dim dic As Object, res As Object, d As Variant, i As Long, p As Long
Dim j As Long, x As Variant, op() As Variant, w as Variant

    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
    Range("C:ZZ").ClearContents
    
    Call PermutationsNP(dic, res, p, 0, "")
    
    ReDim op(1 To res.Count, 1 To p)
    i = 1
    For Each x In res
        w = Split(res(x), "|")
        For j = 1 To p
            op(i, j) = w(j - 1)
        Next j
        i = i + 1
    Next x
    Range("C1").Resize(res.Count, p).Value = op
    
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

It does the TextToColumns using VBA code instead of the built-in method.

 

[David J Braden]

This does it in a clean way:
Function SampleCellsNoReplace(data As Range, ByVal SampleSize As Long) As Variant
'Returns a sample, without replacement, of Samplesize from a column of cells
'PLEASE retain all comments:
'Written and posted 1999/4/1 to microsoft.public.excel.misc by David J Braden
'Originally posted as "HGSample"

Dim hiP1 As Long, i As Long, j As Long
Dim ret() As Variant, temp As Variant

Application.Volatile 'comment out this line for single shot

temp = data
hiP1 = data.Rows.Count + 1
'If SampleSize > UBound(temp) Then SampleSize = UBound(temp)
ReDim ret(1 To SampleSize, 1 To 1)
For i = 1 To SampleSize
j = i + Int(Rnd * (hiP1 - i))
ret(i, 1) = temp(j, 1): temp(j, 1) = temp(i, 1)
Next i
SampleCellsNoReplace = ret
End Function

 

[David J Braden]

This does it in a clean way:
Function SampleCellsNoReplace(data As Range, ByVal SampleSize As Long) As Variant
'Returns a sample, without replacement, of Samplesize from a column of cells
'PLEASE retain all comments:
'Written and posted 1999/4/1 to microsoft.public.excel.misc by David J Braden
'Originally posted as "HGSample"

Dim hiP1 As Long, i As Long, j As Long
Dim ret() As Variant, temp As Variant

Application.Volatile 'comment out this line for single shot

temp = data
hiP1 = data.Rows.Count + 1
'If SampleSize > UBound(temp) Then SampleSize = UBound(temp)
ReDim ret(1 To SampleSize, 1 To 1)
For i = 1 To SampleSize
j = i + Int(Rnd * (hiP1 - i))
ret(i, 1) = temp(j, 1): temp(j, 1) = temp(i, 1)
Next i
SampleCellsNoReplace = ret
End Function

Just realized you want permutations, not samples. Sorry for mis-post

 

[Chyke_mxl]

You shouldn't have to edit the code, it should work as is. I'm trying to figure out why the TextToColumns line didn't work. If you can't figure it out either, then you can try this version:

Sub Permutations()
Dim dic As Object, res As Object, d As Variant, i As Long, p As Long
Dim j As Long, x As Variant, op() As Variant, w as Variant

    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
    Range("C:ZZ").ClearContents
   
    Call PermutationsNP(dic, res, p, 0, "")
   
    ReDim op(1 To res.Count, 1 To p)
    i = 1
    For Each x In res
        w = Split(res(x), "|")
        For j = 1 To p
            op(i, j) = w(j - 1)
        Next j
        i = i + 1
    Next x
    Range("C1").Resize(res.Count, p).Value = op
   
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

It does the TextToColumns using VBA code instead of the built-in method.

Hello Eric.

It worked perfect this time.
Thank you.

Cheers