all combinations without repeats

RICH1980 · Mar 28, 2019

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 · Apr 26, 2019

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 · Apr 26, 2019

Hi

thanks, the combinations were limited; some where missing.

my latest one kinda works but needs adapting.

MickG · Apr 26, 2019

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

Code:

[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 · Apr 26, 2019

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 · Apr 26, 2019

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

Code:

[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 · Apr 26, 2019

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

[Table="width:, class:grid"][tr][td="bgcolor:#C0C0C0"][/td][td="bgcolor:#C0C0C0"]

B

[/td][td="bgcolor:#C0C0C0"]

C

[/td][/tr][tr][td="bgcolor:#C0C0C0"]

2

[/td][td="bgcolor:#F3F3F3"]

n