Excel VBA Combinations/Permutations

[andrew_sampson]

Hi Guys,

I'm really struggling to get the answer to the following question and hope you can help.

I have a list with items 1, 2 and 3.

How can I create a list that gives the following results: 1, 2, 3, 12, 13, 23 & 123

I know I can just use 3 For loops but I want the code to be able to cope with x numbers in the list. For example 1, 2, 3, 4 and 5 or 1, 2, 3, 4, 5, 6, 7, 8 and 9

Any help would be greatly appreciated

[pgc01]

Hi Andrew
Welcome to the board

You want to calculate the Power Set of a Set.

You can try this code:

Option Explicit
 
' PGC Oct 2007
' Calculates a Power Set
' Set in A1, down. Result in C1, down and accross. Clears C:Z.
Sub PowerSet()
Dim vElements As Variant, vresult As Variant
Dim lRow As Long, i As Long
 
vElements = Application.Transpose(Range("A1", Range("A1").End(xlDown)))
Columns("C:Z").Clear
 
lRow = 1
For i = 1 To UBound(vElements)
    ReDim vresult(1 To i)
    Call CombinationsNP(vElements, i, vresult, lRow, 1, 1)
Next i
End Sub
 
Sub CombinationsNP(vElements As Variant, p As Long, vresult As Variant, lRow As Long, iElement As Integer, iIndex As Integer)
Dim i As Long
 
For i = iElement To UBound(vElements)
    vresult(iIndex) = vElements(i)
    If iIndex = p Then
        lRow = lRow + 1
        Range("C" & lRow).Resize(, p) = vresult
    Else
        Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1)
    End If
Next i
End Sub

Test:

- Write a, b, c, d in A1:A4
- run PowerSet

	A	B	C	D	E	F	G
1	a
2	b		a
3	c		b
4	d		c
5			d
6			a	b
7			a	c
8			a	d
9			b	c
10			b	d
11			c	d
12			a	b	c
13			a	b	d
14			a	c	d
15			b	c	d
16			a	b	c	d
17
[Book1]Sheet1

[andrew_sampson]

Exactly what i was looking for!!

Thanks very much pgc01

[mountainclimber11]

Hello,

I'm looking for the same thing except for permutations...ie order does matter so for 3 #'s or letters I will get 3^1 + 3^2 + 3^3 answers, or 39. But just like his original question, I don't know how many I'll have to start with.

Thanks!

[pgc01]

Hello,

I'm looking for the same thing except for permutations...ie order does matter so for 3 #'s or letters I will get 3^1 + 3^2 + 3^3 answers, or 39. But just like his original question, I don't know how many I'll have to start with.

Hi mountainclimber11

n + n^2 + n^3 + ... + n^n

This is a geometric progression, the total is:

n * (n^n - 1) / (n - 1)

In the case of 3 elements the total is:

3 * (3^3 - 1) / (3 - 1) = 3 * 26 / 2 = 39

The code is similar to the PowerSet but simpler as now you simply loop through all the values.

Insert in a module and run:

Option Explicit
 
' PGC Dez 2009
' Permutations of N elements taken 1 to p at a time
' Set in A1, down. Result in C1, down and accross. Clears C:Z.
Sub PermutationsN_1ToP_R()
Dim vElements As Variant, vresult As Variant
Dim lRow As Long, i As Long
 
vElements = Application.Transpose(Range("A1", Range("A1").End(xlDown)))
Columns("C:Z").Clear
 
For i = 1 To UBound(vElements)
    ReDim vresult(1 To i)
    Call PermutationsNPR(vElements, i, vresult, lRow, 1)
Next i
End Sub
 
Sub PermutationsNPR(vElements As Variant, p As Long, vresult As Variant, lRow As Long, iIndex As Integer)
Dim i As Long
 
For i = 1 To UBound(vElements)
    vresult(iIndex) = vElements(i)
    If iIndex = p Then
        lRow = lRow + 1
        Range("C" & lRow).Resize(, p) = vresult
    Else
        Call PermutationsNPR(vElements, p, vresult, lRow, iIndex + 1)
    End If
Next i
End Sub

Ex, for 3 elements:

	A	B	C	D	E	F
1	a		a
2	b		b
3	c		c
4			a	a
5			a	b
6			a	c
7			b	a
8			b	b
9			b	c
10			c	a
11			c	b
12			c	c
13			a	a	a
14			a	a	b
15			a	a	c
16			a	b	a
17			a	b	b
18			a	b	c
19			a	c	a
20			a	c	b
21			a	c	c
22			b	a	a
23			b	a	b
24			b	a	c
25			b	b	a
26			b	b	b
27			b	b	c
28			b	c	a
29			b	c	b
30			b	c	c
31			c	a	a
32			c	a	b
33			c	a	c
34			c	b	a
35			c	b	b
36			c	b	c
37			c	c	a
38			c	c	b
39			c	c	c
40
[Book2]Sheet6

[mountainclimber11]

Hey, thanks! My fault, I should have said 33 not 39 or 15 sets because I don't want the lines that have all the same letter (aaa, bb, cc, etc.), but your posted answers my question. This is what I ended up using:

Sub comboze()
Dim z, y() As String, u As Integer, v As Integer
Dim a As Integer, b As Long, c As Integer, d As Integer
Dim w(), g, ct, i, j, kk
z = Array("a", "b", "c")
u = UBound(z) + 1
v = u
ReDim y(1 To u ^ v, 1 To v), w(1 To u ^ v, 1 To v)
For a = 1 To v
    For b = 1 To u ^ v Step u ^ a
        For c = b To b + u ^ (a - 1) - 1
            For d = 1 To u
                y(c + u ^ (a - 1) * (d - 1), v - a + 1) = z(d - 1)
Next d, c, b, a
n = u ^ v: m = v
With CreateObject("Scripting.Dictionary")
    For i = 1 To n
        For j = 1 To m
            .Item(y(i, j)) = .Item(y(i, j)) + 1
        Next j
        kk = .keys
        For a = 1 To .Count
            w(i, a) = kk(a - 1)
        Next a
        .removeall
    Next i
For i = 1 To n
    g = Empty
    For j = 1 To m: g = g & Chr(30) & w(i, j): Next j
    If Not .exists(g) Then
        .Add g, Empty
        ct = ct + 1
        For j = 1 To m: w(ct, j) = w(i, j): Next j
    End If
Next i
End With
Range("A1").Resize(ct, m) = w
End S

From this thread:
http://www.mrexcel.com/forum/showthr...44#post2164844

Thanks!

[crakonit]

Hi All,

This method "PowerSet" to work the combinations out is certainly really impressive!

Is it possible to get the PowerSet Code adjusted so it also considers its own velements?.

I mean, when running the code based on 'A' and 'B' and 'C'

It will return:
A
B
C
A B
A C
B C
A B C



I need it to return:

A
B
C
A A
A B
A C
B B
B C
C C
A A A
A A B
A A C
A B B
A B C
A C C
B B B
B B C
B C C
C C C

At the moment I can get the desired result by writing each elements 3 times, ie:

A
A
A
B
B
B
C
C
C

Once I have the results (by running the powerset code), I remove all the duplicate rows from the results (using excel 'remove duplicate').

The method works fine until I start increasing the number of letters, simply because excel will not handle so much data. The must be a way to do this without duplicating the elements then removing duplicates.

Please help!
Thanks

[pgc01]

Hi
Welcome to the board

With the set of elements in A1, down, try:

Sub PowerSetRept()
Dim vElements As Variant, vresult As Variant
Dim lRow As Long, i As Long
 
vElements = Application.Transpose(Range("A1", Range("A1").End(xlDown)))
Columns("C:Z").Clear
 
lRow = 1
For i = 1 To UBound(vElements)
    ReDim vresult(1 To i)
    Call CombinationsNP(vElements, i, vresult, lRow, 1, 1)
Next i
End Sub
 
Sub CombinationsNP(vElements As Variant, p As Long, vresult As Variant, lRow As Long, iElement As Long, iIndex As Long)
Dim i As Long
 
For i = iElement To UBound(vElements)
    vresult(iIndex) = vElements(i)
    If iIndex = p Then
        lRow = lRow + 1
        Range("C" & lRow).Resize(, p) = vresult
    Else
        Call CombinationsNP(vElements, p, vresult, lRow, i, iIndex + 1)
    End If
Next i
End Sub

	A	B	C	D	E	F
1	a
2	b		a
3	c		b
4			c
5			a	a
6			a	b
7			a	c
8			b	b
9			b	c
10			c	c
11			a	a	a
12			a	a	b
13			a	a	c
14			a	b	b
15			a	b	c
16			a	c	c
17			b	b	b
18			b	b	c
19			b	c	c
20			c	c	c
21
[Book1]Sheet2

[crakonit]

Thanks.

This is exactly what I was after!

Thank you ever so much for doing this =)

[crakonit]

Hi Again...

What would be the formula to work out the results of CombRept based on given no of elements?

Say I have 2 elements, I need to know (before I run CombRept):
how many rows of data will contain 1 element (=2),
how many rows of data will contain 2 elements (=3).

Say I have 4 elements, I need to know (before I run CombRept):
how many rows of data will contain 1 elements(=4),
how many rows of data will contain 2 elements(=10)
how many rows of data will contain 3 elements (=20)
how many rows of data will contain 4 elements (=35)

The build-in COMBIN does really tell the that.

Thanks!