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

 

[MickG]

Try this, for results starting "A1".

[COLOR="Navy"]Sub[/COLOR] MG29Mar49
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim ray(1 To Rng.Count, 1 To Rng.Count)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    c = c + 1
    [COLOR="Navy"]For[/COLOR] Ac = 1 To c
        ray(c, Ac) = Rng(Ac)
    [COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]Next[/COLOR] Dn
Range("A1").Resize(c, c) = ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[RICH1980]

Hi Mick,

Thanks for your reply and for this. However, in addition to this - I need all possible combinations.

EG.

A, AB, AC, AD, AE, AF
B, BC, BD, BF, BCD, BCF,
C, CD, CE CEF,
D, DB,

and so on

AB and BA would be the same, as would ABC, CBA... so these are not needed - just the unique combinations.

Thanks for your support anyhow.

 

[RICH1980]

So I have found this and have been trying to adapt it - but rather than the result being in the one cell (b1) I'm trying to get the items in separate cells from b2.

If you fill in the boxed a1 - a10 with different words you'll see what I mean.

Function ListSubsets(Items As Variant) As String
Dim CodeVector() As Integer
Dim i 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
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
'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
ListSubsets = SubList
End Function
Sub TestThis()
Dim B As Variant

B = Array((Cells(1, 1)), (Cells(2, 1)), (Cells(3, 1)), (Cells(4, 1)), (Cells(5, 1)), (Cells(6, 1)), (Cells(7, 1)), (Cells(8, 1)), (Cells(9, 1)), (Cells(10, 1)))
Cells(1, 2).Value = ListSubsets(B)

MsgBox ListSubsets(B)
End Sub

 

[lrobbo314]

I tested this on your ABCDEF example, where A is in A1, B is in A2, and so on. The results get output to column B. It limits it to groups of 3. I commented the line of code you can modify to change group size. These were the results I got from the ABC example.

[TABLE="width: 64"]
<colgroup><col width="64" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"]A[/TD]
[/TR]
[TR]
[TD]B[/TD]
[/TR]
[TR]
[TD]C[/TD]
[/TR]
[TR]
[TD]D[/TD]
[/TR]
[TR]
[TD]E[/TD]
[/TR]
[TR]
[TD]F[/TD]
[/TR]
[TR]
[TD]AB[/TD]
[/TR]
[TR]
[TD]BC[/TD]
[/TR]
[TR]
[TD]CD[/TD]
[/TR]
[TR]
[TD]DE[/TD]
[/TR]
[TR]
[TD]EF[/TD]
[/TR]
[TR]
[TD]ABC[/TD]
[/TR]
[TR]
[TD]BCD[/TD]
[/TR]
[TR]
[TD]CDE[/TD]
[/TR]
[TR]
[TD]DEF


[/TD]
[/TR]
</tbody>[/TABLE]

Here's the code...

Sub Combinations()
Dim AR() As Variant: AR = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
Dim SD As Object: Set SD = CreateObject("System.Collections.ArrayList")


Combo AR, SD, 1, 1
Range("B1").Resize(SD.Count, 1).Value = Application.Transpose(SD.toarray)


End Sub


Sub Combo(AR As Variant, SD As Object, Group As Integer, IDX As Integer)
Dim Res As String
If IDX = 1 And Group > 3 Then Exit Sub 'change this line to increase group number


For i = IDX To IDX + Group - 1
    Res = Res & AR(i, 1)
Next i


SD.Add Res


If IDX = UBound(AR) - Group + 1 Then
    Group = Group + 1
    IDX = 0
End If


Combo AR, SD, Group, IDX + 1


End Sub

 

[DanteAmor]

Check this

Myrna Larson code:
https://www.mrexcel.com/forum/excel...ns-not-working-excel-2007-overflow-error.html

https://app.box.com/s/f3puhccnqa

https://app.box.com/s/b9b9fc06beb63b9562f9

 

[lrobbo314]

Had to adjust the code to get all of the combinations. Here is the code.

Sub Combinations()
Dim AR() As Variant: AR = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
Dim SD As Object: Set SD = CreateObject("System.Collections.ArrayList")


Combo AR, SD, 1, 1
Range("B1").Resize(SD.Count, 1).Value = Application.Transpose(SD.toarray)


End Sub


Sub Combo(AR As Variant, SD As Object, Group As Integer, IDX As Integer)
Dim Res As String
If IDX = 1 And Group > 6 Then Exit Sub 'change this line to increase group number


If Group > 1 Then
    For i = IDX + 1 To UBound(AR) - Group + 2
        Res = AR(IDX, 1)
        For j = i To i + (Group - 1) - 1
            Res = Res & AR(j, 1)
        Next j
        SD.Add Res
        Res = vbNullString
    Next i
Else
    SD.Add AR(IDX, 1)
End If


If IDX = UBound(AR) - Group + 1 Then
    Group = Group + 1
    IDX = 0
End If


Combo AR, SD, Group, IDX + 1


End Sub

Here are the results.

[TABLE="width: 64"]
<colgroup><col width="64" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"]A[/TD]
[/TR]
[TR]
[TD]B[/TD]
[/TR]
[TR]
[TD]C[/TD]
[/TR]
[TR]
[TD]D[/TD]
[/TR]
[TR]
[TD]E[/TD]
[/TR]
[TR]
[TD]F[/TD]
[/TR]
[TR]
[TD]AB[/TD]
[/TR]
[TR]
[TD]AC[/TD]
[/TR]
[TR]
[TD]AD[/TD]
[/TR]
[TR]
[TD]AE[/TD]
[/TR]
[TR]
[TD]AF[/TD]
[/TR]
[TR]
[TD]BC[/TD]
[/TR]
[TR]
[TD]BD[/TD]
[/TR]
[TR]
[TD]BE[/TD]
[/TR]
[TR]
[TD]BF[/TD]
[/TR]
[TR]
[TD]CD[/TD]
[/TR]
[TR]
[TD]CE[/TD]
[/TR]
[TR]
[TD]CF[/TD]
[/TR]
[TR]
[TD]DE[/TD]
[/TR]
[TR]
[TD]DF[/TD]
[/TR]
[TR]
[TD]EF[/TD]
[/TR]
[TR]
[TD]ABC[/TD]
[/TR]
[TR]
[TD]ACD[/TD]
[/TR]
[TR]
[TD]ADE[/TD]
[/TR]
[TR]
[TD]AEF[/TD]
[/TR]
[TR]
[TD]BCD[/TD]
[/TR]
[TR]
[TD]BDE[/TD]
[/TR]
[TR]
[TD]BEF[/TD]
[/TR]
[TR]
[TD]CDE[/TD]
[/TR]
[TR]
[TD]CEF[/TD]
[/TR]
[TR]
[TD]DEF[/TD]
[/TR]
[TR]
[TD]ABCD[/TD]
[/TR]
[TR]
[TD]ACDE[/TD]
[/TR]
[TR]
[TD]ADEF[/TD]
[/TR]
[TR]
[TD]BCDE[/TD]
[/TR]
[TR]
[TD]BDEF[/TD]
[/TR]
[TR]
[TD]CDEF[/TD]
[/TR]
[TR]
[TD]ABCDE[/TD]
[/TR]
[TR]
[TD]ACDEF[/TD]
[/TR]
[TR]
[TD]BCDEF[/TD]
[/TR]
[TR]
[TD]ABCDEF[/TD]
[/TR]
</tbody>[/TABLE]

 

[RICH1980]

Hi, Thanks Irobbo and DanteAmor for your response.

The above works well, but is limited. - but I need it to be all combinations, rather than 3, up to 12 entries.

Ive played with the https://app.box.com/s/b9b9fc06beb63b9562f9

above from DanteAmor

​

- which does kind of what I need, but I do not need all the fancy stuff. I need to put the entries in column (A) rather than the one cell.... and get the results in column (B)

I've also found this but cant get it to work -so I don't know if it will do the job.

Sub Combinations()
'Ref PCG
Dim rRng As Range, p
Dim vElements, lRow As Long, vresult As Variant
Set rRng =Range("A1", Range("A1").End(xlDown))
p = 4
vElements = Application.Index(Application.Transpose(rRng),1, 0)
ReDim vresult(1 To p)
Call CombinationsNP(vElements, CInt(p), vresult, lRow, 1, 1)
End Sub

Sub CombinationsNP(vElements As Variant, p As Integer,vresult As Variant, lRow As Long, iElement As Integer, iIndex As Integer)
Dim i As Integer
For i = iElement To UBound(vElements)
vresult(iIndex) = vElements(i)
If iIndex = p Then
lRow = lRow +1
Range("B" & lRow) = Join(vresult, ", ")
'Range("C" & lRow).Resize(, p) = vresult'Multi columnResult
Else
CallCombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1)
End If
Next i
End Sub


​

 

[lrobbo314]

Did you try the code I posted in my second post? What about it isn't doing what you are looking for?

 

[DanteAmor]

You're welcome.

If the code works for you, start removing fancy stuff. I guess it's more practical than creating a new code.