all combinations without repeats

[RICH1980]

Hi, I am unsure if this already exists but have spent days looking for what I need and cannot find it.

What I am looking for is a VBA that will provide all possible unique combinations within a range.

The range will be variable to input - in column A from 1 to 12 entries.

Lets say-

A1 - cat
A2 - dog
A3 - cow
A4 - pig

Without repetition I would like it come back with the possible combinations up to 12 entries, ideally in separate cell.

b1 cat
b2 cat c3 dog
b3 cat c3 dog d3 cow
b4 cat c4 dog d4 cow e4 pig

In this case

b2 dog and c3 cat would be the same as above and not needed as not a unique combination.

Any ideas, thanks in advance

 

[RICH1980]

Hi

I'm still working on this.

This is only part of what I need really but it would really be of help with amending it.

a) I would like for the array to be linked to a range c3:c8 and ignore blanks
b) I would like the combinations to be in different cells - rather the same one as I need to look up values from a cell fomula.
c) If possible - to have have a gap of two rows between each combination set.

The 'loans' below are in a table - the amount of loans will vary.




Sub MAIN()
B = Array("Loan 1", "Loan 2", "Loan 3", "Loan 4", "Loan 5", "Loan 6")
Call GrayCode(B)
End Sub

Function GrayCode(Items As Variant) As String
Dim CodeVector() As Integer
Dim i, kk As Integer
Dim lower As Integer, upper As Integer
Dim SubList As String
Dim NewSub As String
Dim done As Boolean
Dim OddStep As Boolean
kk = 2
OddStep = True
lower = LBound(Items)
upper = UBound(Items)
ReDim CodeVector(lower To upper) 'it starts all 0
Do Until done
'Add a new subset according to current contents
'of CodeVector
NewSub = ""
For i = lower To upper
If CodeVector(i) = 1 Then
If NewSub = "" Then
NewSub = "," & Items(i)
Else
NewSub = NewSub & Items(i)
End If
End If
Next i
If NewSub = "" Then NewSub = "{}" 'empty set
SubList = SubList & vbCrLf & NewSub
Cells(30, kk) = Mid(NewSub, 2)
kk = kk + 1
'now update code vector
If OddStep Then
'just flip first bit
CodeVector(lower) = 1 - CodeVector(lower)
Else
'first locate first 1
i = lower
Do While CodeVector(i) <> 1
i = i + 1
Loop
'done if i = upper:
If i = upper Then
done = True
Else
'if not done then flip the *next* bit:
i = i + 1
CodeVector(i) = 1 - CodeVector(i)
End If
End If
OddStep = Not OddStep 'toggles between even and odd steps
Loop
GrayCode = SubList
End Function

 

[RICH1980]

Hi

thanks, the combinations were limited; some where missing.

my latest one kinda works but needs adapting.

 

[MickG]

Perhaps this might help !!!
Your data in "C3:C8", Results Start "E1".

[COLOR="Navy"]Sub[/COLOR] MG26Apr32
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range, Rng [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] rRng [COLOR="Navy"]As[/COLOR] Range, p, n, nRay, w [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] vElements, lRow [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] vresult [COLOR="Navy"]As[/COLOR] Variant
nRay = Range(Range("C3"), Range("C" & Rows.Count).End(xlUp))
c = 1
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(nRay)
    vElements = Application.Transpose(nRay)
        ReDim vresult(1 To n)
            Call CombinationsNP(vElements, CInt(n), vresult, lRow, 1, 1, c)
[COLOR="Navy"]Next[/COLOR] n
[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"]Integer,[/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] c)
[COLOR="Navy"]Dim[/COLOR] i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]

[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
         
         Range("E" & c).Resize(, UBound(vresult)).Value = vresult
        c = c + 3
    [COLOR="Navy"]Else[/COLOR]
        Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1, c)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] i
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[RICH1980]

Hi, thanks.

Very quick. Work great.

I'm working on, what for me is complex, so hopefully this will aide with the first step.

Ieally i need this part to go across rather than down - as the next step (if this bit works) is to have another combination vba for an array above each combination.

Thank you so much

 

[MickG]

Try this for results going across columns starting in "E1".

[COLOR="Navy"]Sub[/COLOR] MG26Apr48

[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range, Rng [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] rRng [COLOR="Navy"]As[/COLOR] Range, p, n, nRay, w [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] vElements, lRow [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] vresult [COLOR="Navy"]As[/COLOR] Variant
nRay = Range(Range("C3"), Range("C" & Rows.Count).End(xlUp))
c = 5
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(nRay)
    vElements = Application.Transpose(nRay)
        ReDim vresult(1 To n)
            Call CombinationsNP(vElements, CInt(n), vresult, lRow, 1, 1, c)
[COLOR="Navy"]Next[/COLOR] n
[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"]Integer,[/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] c)
[COLOR="Navy"]Dim[/COLOR] i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]

[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="Green"][B] Range("E" & c).Resize(, UBound(vresult)).Value = vresult[/B][/COLOR]
         Cells(1, c).Resize(UBound(vresult)).Value = Application.Transpose(vresult)
         c = c + 3
    [COLOR="Navy"]Else[/COLOR]
        Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1, c)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] i
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[shg]

There's a workbook at https://app.box.com/s/b9b9fc06beb63b9562f9 that will do this:

	B​	C​
2​	n​
3​	7​
4​	mMin​
5​	1 ​
6​	mMax​
7​	6 ​
8​	nComb​
9​	126​
10​
11​	m​	Ant Bee Cow Dog Emu Flea Gnat
12​	1​	Ant
13​	1​	Bee
14​	1​	Cow
15​	1​	Dog
16​	1​	Emu
17​	1​	Flea
18​	1​	Gnat
19​	2​	Bee Ant
20​	2​	Cow Ant
21​	2​	Cow Bee
22​	2​	Dog Ant
23​	2​	Dog Bee
24​	2​	Dog Cow
25​	2​	Emu Ant
26​	2​	Emu Bee
27​	2​	Emu Cow
28​	2​	Emu Dog
29​	2​	Flea Ant
30​	2​	Flea Bee
31​	2​	Flea Cow
32​	2​	Flea Dog
33​	2​	Flea Emu
34​	2​	Gnat Ant
35​	2​	Gnat Bee
36​	2​	Gnat Cow
37​	2​	Gnat Dog
38​	2​	Gnat Emu
39​	2​	Gnat Flea
40​	3​	Cow Bee Ant
41​	3​	Dog Bee Ant
42​	3​	Dog Cow Ant
43​	3​	Dog Cow Bee
44​	3​	Emu Bee Ant
45​	3​	Emu Cow Ant
46​	3​	Emu Cow Bee
47​	3​	Emu Dog Ant
48​	3​	Emu Dog Bee
49​	3​	Emu Dog Cow
50​	3​	Flea Bee Ant
51​	3​	Flea Cow Ant
52​	3​	Flea Cow Bee
53​	3​	Flea Dog Ant
54​	3​	Flea Dog Bee
55​	3​	Flea Dog Cow
56​	3​	Flea Emu Ant
57​	3​	Flea Emu Bee
58​	3​	Flea Emu Cow
59​	3​	Flea Emu Dog
60​	3​	Gnat Bee Ant
61​	3​	Gnat Cow Ant
62​	3​	Gnat Cow Bee
63​	3​	Gnat Dog Ant
64​	3​	Gnat Dog Bee
65​	3​	Gnat Dog Cow
66​	3​	Gnat Emu Ant
67​	3​	Gnat Emu Bee
68​	3​	Gnat Emu Cow
69​	3​	Gnat Emu Dog
70​	3​	Gnat Flea Ant
71​	3​	Gnat Flea Bee
72​	3​	Gnat Flea Cow
73​	3​	Gnat Flea Dog
74​	3​	Gnat Flea Emu
75​	4​	Dog Cow Bee Ant
76​	4​	Emu Cow Bee Ant
77​	4​	Emu Dog Bee Ant
78​	4​	Emu Dog Cow Ant
79​	4​	Emu Dog Cow Bee
80​	4​	Flea Cow Bee Ant
81​	4​	Flea Dog Bee Ant
82​	4​	Flea Dog Cow Ant
83​	4​	Flea Dog Cow Bee
84​	4​	Flea Emu Bee Ant
85​	4​	Flea Emu Cow Ant
86​	4​	Flea Emu Cow Bee
87​	4​	Flea Emu Dog Ant
88​	4​	Flea Emu Dog Bee
89​	4​	Flea Emu Dog Cow
90​	4​	Gnat Cow Bee Ant
91​	4​	Gnat Dog Bee Ant
92​	4​	Gnat Dog Cow Ant
93​	4​	Gnat Dog Cow Bee
94​	4​	Gnat Emu Bee Ant
95​	4​	Gnat Emu Cow Ant
96​	4​	Gnat Emu Cow Bee
97​	4​	Gnat Emu Dog Ant
98​	4​	Gnat Emu Dog Bee
99​	4​	Gnat Emu Dog Cow
100​	4​	Gnat Flea Bee Ant
101​	4​	Gnat Flea Cow Ant
102​	4​	Gnat Flea Cow Bee
103​	4​	Gnat Flea Dog Ant
104​	4​	Gnat Flea Dog Bee
105​	4​	Gnat Flea Dog Cow
106​	4​	Gnat Flea Emu Ant
107​	4​	Gnat Flea Emu Bee
108​	4​	Gnat Flea Emu Cow
109​	4​	Gnat Flea Emu Dog
110​	5​	Emu Dog Cow Bee Ant
111​	5​	Flea Dog Cow Bee Ant
112​	5​	Flea Emu Cow Bee Ant
113​	5​	Flea Emu Dog Bee Ant
114​	5​	Flea Emu Dog Cow Ant
115​	5​	Flea Emu Dog Cow Bee
116​	5​	Gnat Dog Cow Bee Ant
117​	5​	Gnat Emu Cow Bee Ant
118​	5​	Gnat Emu Dog Bee Ant
119​	5​	Gnat Emu Dog Cow Ant
120​	5​	Gnat Emu Dog Cow Bee
121​	5​	Gnat Flea Cow Bee Ant
122​	5​	Gnat Flea Dog Bee Ant
123​	5​	Gnat Flea Dog Cow Ant
124​	5​	Gnat Flea Dog Cow Bee
125​	5​	Gnat Flea Emu Bee Ant
126​	5​	Gnat Flea Emu Cow Ant
127​	5​	Gnat Flea Emu Cow Bee
128​	5​	Gnat Flea Emu Dog Ant
129​	5​	Gnat Flea Emu Dog Bee
130​	5​	Gnat Flea Emu Dog Cow
131​	6​	Flea Emu Dog Cow Bee Ant
132​	6​	Gnat Emu Dog Cow Bee Ant
133​	6​	Gnat Flea Dog Cow Bee Ant
134​	6​	Gnat Flea Emu Cow Bee Ant
135​	6​	Gnat Flea Emu Dog Bee Ant
136​	6​	Gnat Flea Emu Dog Cow Ant
137​	6​	Gnat Flea Emu Dog Cow Bee

You can use text to columns to split them to separate cells.

 

[RICH1980]

Hi Mick

You are a complete legend. This works perfect. thank you.

I've put an array above each calculation. I'm thinking of opening a new thread for the next step - as although still a combination thread - this will be for multiple ranges (well up to 63 ranges)

Thanks again

 

[RICH1980]

Hi Thanks for this - but not what I'm after really- Mick's solution has helped.