Permutations without Repetition No Row Constraint

[KSKUSE]

Hi!

I'm extremely novice at VBA. I'm trying to mash two codes I found online, but obviously it's not that easy. I'm trying to find a code that will return all permutations without repetition and no row constraint (i.e. the permutation of 10 options with 7 selections).

This is what I have so far:

Option Explicit
    
Function ListPermut(num As Integer)
'Permutations without repetition

Dim a As Integer
Dim b As Integer
Dim x As Integer
Dim z As Integer
Dim e As Integer
Dim f As Integer
Dim n As Long
Dim c As Long, r As Long, p As Long
Dim rng() As Long, temp As Long, i As Long
Dim temp1 As Long, y() As Long, d As Long
p = WorksheetFunction.Permut(num, num)
    
Dim maxRows As Long
Dim sheetNumber As Integer
Dim loopCounter As Integer
 maxRows = 1048576
 loopCounter = 38
 sheetNumber = 1
 n = 1
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Sheet-" & sheetNumber
Application.ScreenUpdating = False
For a = 1 To loopCounter
For b = 1 To loopCounter
    For x = 1 To loopCounter
        For z = 1 To loopCounter
            For e = 1 To loopCounter
                For f = 1 To loopCounter

                  Cells(n, 1).Value = a
                  Cells(n, 2).Value = b
                  Cells(n, 3).Value = x
                  Cells(n, 4).Value = z
                  Cells(n, 5).Value = e
                  Cells(n, 6).Value = f
                  If n = maxRows Then
                       sheetNumber = sheetNumber + 1
                       ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
                       ActiveSheet.Name = "Sheet-" & sheetNumber
                       n = 0
                  End If
                  n = n + 1
                Next f
            Next e
        Next z
      Next x
    Next b
  Next a
Application.ScreenUpdating = False
' Create array
ReDim rng(1 To p, 1 To num)
 
'Create first row in array (1, 2, 3, ...)
For c = 1 To num
  rng(1, c) = c
Next c
    
For r = 2 To p
' 1. Find the first smaller number rng(r-1, c-1)<rng(r-1,c)
  For c = num To 1 Step -1
    If rng(r - 1, c - 1) < rng(r - 1, c) Then
      temp = c - 1
      Exit For
    End If
  Next c
' Copy values from previous row
  For c = num To 1 Step -1
    rng(r, c) = rng(r - 1, c)
  Next c
' 2. Find a larger number than rng(r-1, temp)as far to the right as possible
  For c = num To 1 Step -1
      If rng(r - 1, c) > rng(r - 1, temp) Then
          temp1 = rng(r - 1, temp)
          rng(r, temp) = rng(r - 1, c)
          rng(r, c) = temp1
          ReDim y(num - temp)
          i = 0
          For d = temp + 1 To num
            y(i) = rng(r, d)
            i = i + 1
          Next d
          i = 0
          For d = num To temp + 1 Step -1
            rng(r, d) = y(i)
            i = i + 1
          Next d
          Exit For
      End If
  Next c
Next r
ListPermut = rng
End Function

Any help to make this work would be much appreciated!

TY!</rng(r-1,c)

 

[Rijnsent]

Hi KSKUSE,

I found and adapted an answer I found on stackoverflow.

Hope this works,

Koen

Function Permutations(items As Variant, r As Long, Optional delim As String = ",") As Variant
' source: https://stackoverflow.com/questions/47391728/generating-permutations-of-multiple-cells-in-excel-based-on-input
    '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, r As Long
    Dim items As Variant
    Dim WriteArr As Variant
    'https://www.calculatorsoup.com/calculators/discretemathematics/permutations.php
    'P(n,r)=P(10,7)= 604800
 
    n = 6
    r = 3

    p = WorksheetFunction.Permut(n, r)
    maxRows = 50 'Rows.Count is the normal value, this 50 is for test purposes, writes 50 results per sheet
 
    ReDim items(1 To n)
    For i = 1 To n
        items(i) = i
    Next i
    items = Permutations(items, r)
    
    'Check the result for size and write to sheet(s)
    NrShts = Int(p / maxRows) + 1
    StartWrite = 1
    
    For Sht = 1 To NrShts
        'Write result array to array so you can write in one block to the sheet
        StartWrite = 1 + (Sht - 1) * maxRows
        If p - StartWrite + 1 > maxRows Then
            WriteRows = maxRows
        Else
            WriteRows = p - StartWrite + 1
        End If
        
        ReDim WriteArr(1 To WriteRows, 1 To 1)
        For Rw = StartWrite To StartWrite + WriteRows - 1
            WriteArr(Rw - StartWrite + 1, 1) = items(Rw)
        Next Rw
        
        'Remove sheet if exists
        Application.DisplayAlerts = False
        On Error Resume Next
        ActiveWorkbook.Worksheets("Permu-" & Sht).Delete
        On Error GoTo 0
        Application.DisplayAlerts = False

        'Add sheet and write
        ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = "Permu-" & Sht
        Set WriteDest = ActiveSheet.Range("A1")
        WriteDest.Resize(UBound(WriteArr, 1), UBound(WriteArr, 2)).Value = WriteArr
    Next Sht
    
End Sub