Combination And Permutation with no repeat - edit the code

[Vishaal]

Hi,

Thanks in advance,

I am using the following VBA code and sheet to generate the permutation:-

Sheet
Excel 2010 32 bit

	A​	B​	C​	D​	E​
1​	p	6​
2​	Combinations	FALSE​
3​	Repetition	TRUE​
4​
5​	Set	0​
6​		1​
7​		2​
8​		3​
9​		4​
10​		5​
11​		6​
12​		7​
13​		8​
14​		9​

Sheet: Sheet1

VBA Code

Option Explicit


' PGC Set 2007
' Calculates and writes the Combinations / Permutations with/without repetition
' Assumes the result is written from row 1 down. If the total number of cells in a column
' is less than tha number of results continues in another group of columns to the right.
' 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 As Integer
Dim vElements As Variant, vResult As Variant, vResultAll As Variant, lTotal As Long
Dim lRow As Long, bComb As Boolean, bRepet As Boolean
Dim vResultPart, iGroup As Integer, l As Long, lMax As Long, k As Long

' Get the inputs and clear the result range (you may adjust for other locations)
Set rRng = Range("B5", Range("B5").End(xlDown)) ' The set of numbers
p = Range("B1").Value ' How many are picked
bComb = Range("B2")
bRepet = Range("B3")
Range("D1", Cells(1, Columns.Count)).EntireColumn.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
Call CombPermNP(vElements, p, bComb, bRepet, vResult, lRow, vResultAll, 1, 1)

' Write the  Combinations / Permutations
' Since writing to the worksheet cell be cell is very slow, uses temporary arrays to write one column at a time
Application.ScreenUpdating = False
If lTotal <= Rows.Count Then
    Range("D1").Resize(lTotal, p).Value = vResultAll
Else
    While iGroup * Rows.Count < lTotal
        lMax = lTotal - iGroup * Rows.Count
        If lMax > Rows.Count Then lMax = Rows.Count
        ReDim vResultPart(1 To lMax, 1 To p)
        For l = 1 To lMax
            For k = 1 To p
                vResultPart(l, k) = vResultAll(l + iGroup * Rows.Count, k)
            Next k
        Next
        Range("D1").Offset(0, iGroup * (p + 1)).Resize(lMax, p).Value = vResultPart
        iGroup = iGroup + 1
    Wend
End If
Application.ScreenUpdating = True
End Sub

Sub CombPermNP(ByVal vElements As Variant, ByVal p As Integer, ByVal bComb As Boolean, ByVal bRepet As Boolean, _
                             ByVal vResult As Variant, ByRef lRow As Long, ByRef vResultAll As Variant, ByVal iElement As Integer, ByVal iIndex As Integer)
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

Now the problem is

1. No repeat
2. when i am using the p = 7, its showing Run-time error 7 and Out of memory (Excel 2010, 64bit)
3. how can i use it for SET = 0 to 99 and p=10 or 25

 

[Vishaal]

its showing

Compile error
Syntax error

on this line

If lRow = N Exit Sub

 

[StephenCrump]

Sorry, my typo.

If lRow = N Then Exit Sub

 

[Vishaal]

Again error

Run time error 9
subscript out of range


ReDim vResultAll(1 To lTotal, 1 To p)

 

[StephenCrump]

Let's ignore the code in Post #10 . I highlighted the changes in red, but perhaps I missed some. I also made a typo. Perhaps you have too, to get this error.

Replace all your code with the code below, and it should work?

Const N = 1000000
Sub CombPerm()
Dim rRng As Range, p As Integer
Dim vElements As Variant, vResult As Variant, vResultAll() As Long, lTotal As Long
Dim lRow As Long, bComb As Boolean, bRepet As Boolean
Dim vResultPart() As Long, iGroup As Integer, l As Long, lMax As Long, k As Long

' Get the inputs and clear the result range (you may adjust for other locations)
Set rRng = Range("B5", Range("B5").End(xlDown)) ' The set of numbers
p = Range("B1").Value ' How many are picked
bComb = Range("B2")
bRepet = Range("B3")
Range("D1", Cells(1, Columns.Count)).EntireColumn.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)
lTotal = N
On Error Resume Next
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
On Error GoTo 0
lTotal = Application.Min(N, lTotal)
ReDim vResult(1 To p)
ReDim vResultAll(1 To lTotal, 1 To p)

' Calculate the Combinations / Permutations
Call CombPermNP(vElements, p, bComb, bRepet, vResult, lRow, vResultAll, 1, 1)

' Write the  Combinations / Permutations
' Since writing to the worksheet cell be cell is very slow, uses temporary arrays to write one column at a time
Application.ScreenUpdating = False
If lTotal <= Rows.Count Then
    Range("D1").Resize(lTotal, p).Value = vResultAll
Else
    While iGroup * Rows.Count < lTotal
        lMax = lTotal - iGroup * Rows.Count
        If lMax > Rows.Count Then lMax = Rows.Count
        ReDim vResultPart(1 To lMax, 1 To p)
        For l = 1 To lMax
            For k = 1 To p
                vResultPart(l, k) = vResultAll(l + iGroup * Rows.Count, k)
            Next k
        Next
        Range("D1").Offset(0, iGroup * (p + 1)).Resize(lMax, p).Value = vResultPart
        iGroup = iGroup + 1
    Wend
End If
Application.ScreenUpdating = True
End Sub

Sub CombPermNP(ByVal vElements As Variant, ByVal p As Integer, ByVal bComb As Boolean, ByVal bRepet As Boolean, _
                             ByVal vResult As Variant, ByRef lRow As Long, ByRef vResultAll As Variant, ByVal iElement As Integer, ByVal iIndex As Integer)
Dim i As Integer, j As Integer, bSkip As Boolean

If lRow = N Then Exit Sub

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
            If lRow = N Then Exit Sub
        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