Combination And Permutation with no repeat - edit the code

V

Vishaal

Well-known Member
Joined
Mar 16, 2019
Messages
543
Office Version
  1. 2010
  2. 2007
Platform
  1. Windows
  2. Web
Hi,

Thanks in advance,

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

Sheet
Excel 2010 32 bit
[Table="width:, class:head"][tr=bgcolor:#E0E0F0][th] [/th][th]
A​
[/th][th]
B​
[/th][th]
C​
[/th][th]
D​
[/th][th]
E​
[/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
1​
[/td][td]p[/td][td]
6​
[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
2​
[/td][td]Combinations[/td][td]
FALSE​
[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
3​
[/td][td]Repetition[/td][td]
TRUE​
[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
4​
[/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
5​
[/td][td]Set[/td][td]
0​
[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
6​
[/td][td][/td][td]
1​
[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
7​
[/td][td][/td][td]
2​
[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
8​
[/td][td][/td][td]
3​
[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
9​
[/td][td][/td][td]
4​
[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
10​
[/td][td][/td][td]
5​
[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
11​
[/td][td][/td][td]
6​
[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
12​
[/td][td][/td][td]
7​
[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
13​
[/td][td][/td][td]
8​
[/td][td][/td][td][/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
14​
[/td][td][/td][td]
9​
[/td][td][/td][td][/td][td][/td][/tr]
[/table][Table="width:, class:grid"][tr][td]Sheet: Sheet1[/td][/tr][/table]


VBA Code

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
 
Sort by date Sort by votes
its showing

Compile error
Syntax error

on this line

If lRow = N Exit Sub
 
Upvote 0

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
Again error

Run time error 9
subscript out of range


ReDim vResultAll(1 To lTotal, 1 To p)
 
Upvote 0
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?

Code: 
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Grouped Unique Combinations Generator
Replies
9
Views
3K
EXCEL MAX
EXCEL MAX
C
  • Locked
  • Question Question
VBA code to list all permutation of N distinct objects of size r without repetition
Replies
6
Views
905
Fluff
Fluff
C
  • Solved
VBA code to list all permutation of N distinct objects of size r without repetition
2
Replies
15
Views
2K
Chyke_mxl
C
M
  • Solved
PGC, code needs help
2
Replies
10
Views
1K
lrobbo314
lrobbo314
montecarlo2012
  • Question Question
[VBA&code] Adding controls to an existing code.
Replies
1
Views
409
montecarlo2012
montecarlo2012

Forum statistics

Threads
1,223,911
Messages
6,175,324
Members
452,635
Latest member
laura12345

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top