Power Set of a Set

[motilulla]

Hello, I found code below under the link shown which is written by pcg01 and it is quite close to my requirement does code could be modified as describe…

http://www.mrexcel.com/forum/excel-...ns-combinations-permutations.html#post2152567

Original Code By pcg01: Calculate the Power Set of a Set

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

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

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1	1
2	17		1
3	22		17
4	33		22
5	44		33
6			44
7			1	17
8			1	22
9			1	33
10			1	44
11			17	22
12			17	33
13			17	44
14			22	33
15			22	44
16			33	44
17			1	17	22
18			1	17	33
19			1	17	44
20			1	22	33
21			1	22	44
22			1	33	44
23			17	22	33
24			17	22	44
25			17	33	44
26			22	33	44
27			1	17	22	33
28			1	17	22	44
29			1	17	33	44
30			1	22	33	44
31			17	22	33	44
32			1	17	22	33	44
pgc01 Set-Up

Now assume numbers are in column A 1-17-22-33-44
Num1 stand in Position1
Num17 stand in Position2
Num22 stand in Position3
Num33 stand in Position4
Num44 stand in Position5

What I need:
Num1 goes in to column C
Num17 goes in to column D
Num22 goes in to column E
Num33 goes in to column F
Num44 goes in to column G

I will use max 14-numbers so 14-position column C to P

In Column Q I want sum of the each row

My Example:

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1	1		P1	P2	P3	P4	P5	P6	P7	P8	P9	P10	P11	P12	P13	P14	Sum
2	17		1														1
3	22			17													17
4	33				22												22
5	44					33											33
6							44										44
7			1	17													18
8			1		22												23
9			1			33	44										78
10			1				44										45
11				17	22												39
12				17		33											50
13				17			44										61
14					22	33											55
15					22		44										66
16						33	44										77
17			1	17	22												40
18			1	17		33											51
19			1	17			44										62
20			1		22	33											56
21			1		22		44										67
22			1			33	44										78
23				17	22	33											72
24				17	22		44										83
25				17		33	44										94
26					22	33	44										99
27			1	17	22	33											73
28			1	17	22		44										84
29			1	17		33	44										95
30			1		22	33	44										100
31				17	22	33	44										116
32			1	17	22	33	44										117
Require

Thank you in advance

Regards,
Moti

 

[motilulla]

Hello, may be it is easy for programmer to generate a new code instead modifying the old one. Please any one can help to create a new one.

Thank you

Regards,
Moti

 

[motilulla]

bump

 

[motilulla]

Bmpu

 

[MickG]

Try pgc's modified code:-

[COLOR="Navy"]Sub[/COLOR] PowerSet()
[COLOR="Navy"]Dim[/COLOR] vElements [COLOR="Navy"]As[/COLOR] Variant, vresult [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] lRow [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
vElements = Application.Transpose(Range("A1", Range("A1").End(xlDown)))
Columns("C:Z").Clear
'[COLOR="Green"][B]#########[/B][/COLOR]
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(vElements)
Dic(vElements(n)) = n + 2
[COLOR="Navy"]Next[/COLOR]
'[COLOR="Green"][B]############[/B][/COLOR]
lRow = 1
[COLOR="Navy"]For[/COLOR] i = 1 To UBound(vElements)
    ReDim vresult(1 To i)
    Call CombinationsNP(vElements, i, vresult, lRow, 1, 1, Dic)
[COLOR="Navy"]Next[/COLOR] i
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
 
[COLOR="Navy"]Sub[/COLOR] CombinationsNP(vElements [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] vresult [COLOR="Navy"]As[/COLOR] Variant, lRow [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] iElement [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] iIndex [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object)
[COLOR="Navy"]Dim[/COLOR] i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] V [COLOR="Navy"]As[/COLOR] Variant
 
[COLOR="Navy"]For[/COLOR] i = iElement To UBound(vElements)
    vresult(iIndex) = vElements(i)
    [COLOR="Navy"]If[/COLOR] iIndex = p [COLOR="Navy"]Then[/COLOR]
        lRow = lRow + 1
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] V [COLOR="Navy"]In[/COLOR] vresult
            Cells(lRow, Dic(V)) = V
            Cells(lRow, "Q") = Application.Sum(Cells(lRow, 3).Resize(, UBound(vElements)). _
            SpecialCells(xlCellTypeConstants))
       [COLOR="Navy"]Next[/COLOR] V
        '[COLOR="Green"][B]Range("C" & lRow).Resize(, p) = vresult[/B][/COLOR]
    [COLOR="Navy"]Else[/COLOR]
        Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1, Dic)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] i
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[motilulla]

Try pgc's modified code:-

[COLOR=Navy]Sub[/COLOR] PowerSet()
[COLOR=Navy]Dim[/COLOR] vElements [COLOR=Navy]As[/COLOR] Variant, vresult [COLOR=Navy]As[/COLOR] Variant, n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] lRow [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] i [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Dic [COLOR=Navy]As[/COLOR] Object
vElements = Application.Transpose(Range("A1", Range("A1").End(xlDown)))
Columns("C:Z").Clear
'[COLOR=Green][B]#########[/B][/COLOR]
[COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] n = 1 To UBound(vElements)
Dic(vElements(n)) = n + 2
[COLOR=Navy]Next[/COLOR]
'[COLOR=Green][B]############[/B][/COLOR]
lRow = 1
[COLOR=Navy]For[/COLOR] i = 1 To UBound(vElements)
    ReDim vresult(1 To i)
    Call CombinationsNP(vElements, i, vresult, lRow, 1, 1, Dic)
[COLOR=Navy]Next[/COLOR] i
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
 
[COLOR=Navy]Sub[/COLOR] CombinationsNP(vElements [COLOR=Navy]As[/COLOR] Variant, p [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] vresult [COLOR=Navy]As[/COLOR] Variant, lRow [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] iElement [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer,[/COLOR] iIndex [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer,[/COLOR] Dic [COLOR=Navy]As[/COLOR] Object)
[COLOR=Navy]Dim[/COLOR] i [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] V [COLOR=Navy]As[/COLOR] Variant
 
[COLOR=Navy]For[/COLOR] i = iElement To UBound(vElements)
    vresult(iIndex) = vElements(i)
    [COLOR=Navy]If[/COLOR] iIndex = p [COLOR=Navy]Then[/COLOR]
        lRow = lRow + 1
        [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] V [COLOR=Navy]In[/COLOR] vresult
            Cells(lRow, Dic(V)) = V
            Cells(lRow, "Q") = Application.Sum(Cells(lRow, 3).Resize(, UBound(vElements)). _
            SpecialCells(xlCellTypeConstants))
       [COLOR=Navy]Next[/COLOR] V
        '[COLOR=Green][B]Range("C" & lRow).Resize(, p) = vresult[/B][/COLOR]
    [COLOR=Navy]Else[/COLOR]
        Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1, Dic)
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] i
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

MickG, speechless result 100% OK

I appreciate a lot your cooperation.

Kind Regards,
Moti

 

[MickG]

You're welcome