Generating permutations of multiple cells in a database based on input

Question

I am trying to generate a total of nPr permutations of words contained in a single column, where 'n' and 'r' are variable. In the example given below, the first column contains the words and second column contains the output.

In this case, n=3 and r=2

Another example, where n=3 and r=3:

So far, I have managed to find a solution in VBA that returns the combinations instead of permutations using below:

Sub Perm()
    Dim i As Long, j As Long, last As Long
    Count = 2
    last = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To last
        For j = i + 1 To last
            Cells(Count, 2).Value = Cells(i, 1).Value & "," & Cells(j, 1).Value
            Count = Count + 1
        Next j
    Next i
End Sub

With this, I'm able to generate combinations with only n as the variable. r is fixed at 2.

What have you tried? If you were able to write code for combinations then it shouldn't be too hard to modify your code for permutations. Perhaps you could show your code. — John Coleman
– John Coleman, Commented Nov 20, 2017 at 12:14
Hey John, here is the code: Sub Perm() Dim i As Long, j As Long, last As Long Count = 2 last = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To last For j = i + 1 To last Cells(Count, 2).Value = Cells(i, 1).Value & "," & Cells(j, 1).Value Count = Count + 1 Next j Next i End Sub With this, I'm able to generate combinations with only n as the variable. r is fixed at 2. — Wafir Manakad
– Wafir Manakad, Commented Nov 20, 2017 at 12:44

John Coleman · Accepted Answer · 2017-11-20 13:32:21Z

3

A recursive approach that will work with any number of items and any r:

Function Permutations(items As Variant, r As Long, Optional delim As String = ",") As Variant
    'items is a 1-based array of items
    'returns all nPr permutations of items
    'returns a 1-based variant array
    'where each item is a delimited string
    'represented the permutation
    'r is assumed to be < n

    Dim n As Long, i As Long, j As Long, k As Long
    Dim rest As Variant, perms As Variant
    Dim item As Variant

    n = UBound(items) 'number of items
    ReDim perms(1 To Application.WorksheetFunction.Permut(n, r))

    If r = 1 Then
        'basis case
        For i = 1 To n
            perms(i) = items(i)
        Next i
    Else
        k = 1
        For i = 1 To n
            item = items(i)
            ReDim rest(1 To n - 1)
            For j = 1 To n - 1
                If j < i Then
                    rest(j) = items(j)
                Else
                    rest(j) = items(j + 1)
                End If
            Next j
            rest = Permutations(rest, r - 1)
            For j = 1 To UBound(rest)
                perms(k) = item & delim & rest(j)
                k = k + 1
            Next j
        Next i
    End If
    Permutations = perms
End Function

Sub test()
    Dim i As Long, n As Long
    Dim items As Variant

    n = Cells(Rows.Count, 1).End(xlUp).Row
    ReDim items(1 To n)
    For i = 1 To n
        items(i) = Cells(i, 1).Value
    Next i
    items = Permutations(items, 3)
    For i = 1 To UBound(items)
        Cells(i, 2).Value = items(i)
    Next i
End Sub

For example:

All the way down to:

(Note that 210 = 7P3).

answered Nov 20, 2017 at 13:32

John Coleman

52.1k7 gold badges59 silver badges127 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

CallumDA Over a year ago

Nice answer, was just putting something similar together as well :)

Wafir Manakad Over a year ago

Wow, recursion at its best, works like a charm. I'm going to dig deeper into the code and understand it better, thanks!

Jochen · Accepted Answer · 2017-11-20 14:20:48Z

Interesting Problem. I solved it with a combination of a sub and function that generates the next level including an option to get all permutationlevels in columns:

Option Explicit

Const Delimiter As String = ", "
Private Base As Variant

Sub Permutations(Inp As Range, Nbr As Integer, OutpStart As Range, Optional All As Boolean = False)
Dim Arr
Dim Perm As Integer
    Base = Inp.Value2
    Arr = Inp.Value2
    For Perm = 2 To Nbr
        Arr = NextPermLvl(Arr)
    Next Perm

    OutpStart.Resize(UBound(Arr), 1).Value = IIf(Nbr = 1, Arr, (Application.Transpose(Arr)))
End Sub

Private Function NextPermLvl(ByVal Arr) As Variant
Dim OutArr() As String: ReDim OutArr(1 To 100000)
Dim OldVal, OldValArr, exst As Boolean, counter As Long
Dim BaseVal, BaseInOldVal
    For Each OldVal In Arr
        OldValArr = Split(OldVal, Delimiter)
        For Each BaseVal In Base
            exst = False
            For Each BaseInOldVal In OldValArr
                If BaseInOldVal = BaseVal Then exst = True: Exit For
            Next BaseInOldVal
            If Not exst Then
                counter = counter + 1
                OutArr(counter) = OldVal & Delimiter & BaseVal
            End If
        Next BaseVal
    Next OldVal
    ReDim Preserve OutArr(1 To counter)
    NextPermLvl = OutArr
End Function

Sub Test()
    Range("G2:G100000").ClearContents
    Permutations Range("A2:A5"), 3, Range("G2")
End Sub

Collectives™ on Stack Overflow

Generating permutations of multiple cells in a database based on input

2 Answers 2

2 Comments

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

2 Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Related