If you would like to post, please check out the MrExcel Message Board FAQ and register here. If you forgot your password, you can reset your password.

Combination And Permutation with no repeat - edit the code

Thread starter Vishaal
Start date Aug 28, 2019
Tags

bcomb brepet end set vba / code

V

Vishaal

Well-known Member

Aug 28, 2019

#1

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

Excel Facts

Spell Check in Excel

Click here to reveal answer

Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)

Sort by date Sort by votes

S

StephenCrump

MrExcel MVP

Aug 28, 2019

#2

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?

Upvote 0

V

Vishaal

Well-known Member

Aug 28, 2019

#3

ok....
than no need

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

Upvote 0

S

StephenCrump

MrExcel MVP

Aug 28, 2019

#4

Vishaal said:
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.

Upvote 0

V

Vishaal

Well-known Member

Aug 28, 2019

#5

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

Last edited: Aug 28, 2019

Upvote 0

S

StephenCrump

MrExcel MVP

Aug 29, 2019

#6

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?

Upvote 0

V

Vishaal

Well-known Member

Aug 29, 2019

#7

o.k.

Last edited: Aug 29, 2019

Upvote 0

V

Vishaal

Well-known Member

Aug 29, 2019

#8

StephenCrump said:
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

Upvote 0

V

Vishaal

Well-known Member

Aug 29, 2019

#9

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

Upvote 0

S

StephenCrump

MrExcel MVP

Aug 29, 2019

#10

Vishaal said:
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.

Code:

[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

Upvote 0

You must log in or register to reply here.

Similar threads

M

Question

Grouped Unique Combinations Generator

Replies: 9

Views: 3K

Sep 6, 2021

EXCEL MAX

C

Locked
Question

VBA code to list all permutation of N distinct objects of size r without repetition

Replies: 6

Views: 912

May 18, 2022

Fluff

C

Solved

VBA code to list all permutation of N distinct objects of size r without repetition

2

Replies: 15

Views: 2K

May 19, 2022

Chyke_mxl

C

M

Solved

PGC, code needs help

2

Replies: 10

Views: 1K

Aug 2, 2021

lrobbo314

Question

[VBA&code] Adding controls to an existing code.

Replies: 1

Views: 415

Oct 15, 2022

montecarlo2012

Share:

Facebook X (Twitter) LinkedIn Reddit Tumblr WhatsApp Email Link

Forum statistics

Threads: 1,224,823

Messages: 6,181,178

Members: 453,021

Latest member: Justyna P

Share this page

Facebook X (Twitter) LinkedIn Reddit Tumblr WhatsApp Email Link

Top