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

 

[StephenCrump]

If I'm reading this correctly, you're looking for permutations of seven numbers out of the 100 unique numbers 0 through 99 inclusive?

That's over 80 trillion permutations.

How long have you got to run this code? And assuming you live that long, where do you want to put the output?

 

[Vishaal]

ok....
than no need

but can i use it with p=7 and set 0 to 9

 

[StephenCrump]

but can i use it with p=7 and set 0 to 9

Give it a try!

The code runs fine on my laptop for this many permutations. But depending on your computer you may encounter problems, e.g. if you want permutations with repetitions:

- You may have problems with this line: ReDim vResultAll(1 To lTotal, 1 To p) if you have insufficient memory, as it creates a variant array of size 10 million x 7. (Although given you are working with integers only, we could squeeeze out a bit more memory by declaring the results arrays as Long instead of Variant)

- 10 million permutations aren't going to fit on one worksheet if you have Excel 2003 or older.

 

[Vishaal]

Thanks for update,

Can you pls share the sheet which you have done in your laptop

I am using Dell company desktop, 6 gb ram, 2 tb hard disk, core i 5 5th generation processor

Excel 2010, 64 bit

I dont need repeat, can you please edit the formula

 

[StephenCrump]

If you set up the sheet as in your Post #1 , but with

B1: 7
B3: FALSE

then the code should generate 604,800 permutations.

Does that work for you, and is that what you are looking for?

 

[Vishaal]

o.k.

 

[Vishaal]

If you set up the sheet as in your Post #1 , but with

B1: 7
B3: FALSE

then the code should generate 604,800 permutations.

Does that work for you, and is that what you are looking for?

Its working bro, thanks

 

[Vishaal]

But when i am trying with B1:10 and set 0 to 99

Its showing the following error

"Run-time error 6

Overflow"

Any solution

 

[StephenCrump]

But when i am trying with B1:10 and set 0 to 99
Its showing the following error
"Run-time error 6
Overflow"

Any solution

No. That's 6 x 10^19 permutations!

Whatever it is that you are trying to do, you'll have to come up with a smarter way than listing all permutations.

FYI though, here's a couple of quick code changes that will let you list the first N (e.g. 1,000,000 here) permutations.

[COLOR=#ff0000][B]Const N = 1000000[/B][/COLOR]
Sub CombPerm()
Dim rRng As Range, p As Integer
Dim vElements As Variant, vResult As Variant, [B][COLOR=#ff0000]vResultAll() As Long[/COLOR][/B], lTotal As Long
Dim lRow As Long, bComb As Boolean, bRepet As Boolean
Dim [COLOR=#ff0000][B]vResultPart() As Long[/B][/COLOR], 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)
[COLOR=#ff0000][B]lTotal = N[/B][/COLOR]
[B][COLOR=#ff0000]On Error Resume Next[/COLOR][/B]
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
[COLOR=#ff0000][B]On Error GoTo 0
lTotal = Application.Min(N, lTotal)
[/B][/COLOR]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

[COLOR=#ff0000][B]If lRow = N Then Exit Sub
[/B][/COLOR]
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
[COLOR=#ff0000][B]            If lRow = N Exit Sub
[/B][/COLOR]        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