Find unique combinations of list of words

[Juizt]

Hello All
I am trying to find all unique combinations of a list of words. The list would ultimately consist of 20-25 words.

Example (with small sample):

Input:
A
B
C

Output:
"A B C"
"A B"
"A C"
"A"
"B C"
"B"
"C"

I have tried using VBA, but as soon as the amount of words exceeds 5 it is a long process and thus not viable for a long list solution. I hope that somebody have had a similar problem and thus had a solution for this problem?

 

[StephenCrump]

Welcome to the Forum!

Assuming there are no duplicate words that you want to suppress, you can generate combinations using the formula below.

The formula can accommodate up to 20 words, in which case you'd need the entire column to display results. For 25 words there are >33 million combinations i.e. 2^25-1.

But why do you need to list all the possibilities? You can carry out any analysis you like using combinatorial formulae, without needing to count the individual possibilities.

	A	B	C	D	E
1
2		A	B	C	D
3
4
5		A
6		B
7		A B
8		C
9		A C
10		B C
11		A B C
12		D
13		A D
14		B D
15		A B D
16		C D
17		A C D
18		B C D
19		A B C D
20
Sheet1

Cell Formulas
Range	Formula
B4:B19	B4	=LET(words,B2:E2,N,COUNTA(words), BYROW(IF(INT(MOD(SEQUENCE(2^N,,0)/2^SEQUENCE(,N,0),2)),words,""),LAMBDA(r,TEXTJOIN(" ",,r))))
Dynamic array formulas.

 

[Legacy 143009]

I guess it is not achievable with formulas. Assuming your letters are from A1:A3, a fast solution can be:

Sub TestRoutine()
    Dim inputt() As Variant, i As Long
    Dim outputt As Variant
    TotalRows = Rows(Rows.Count).End(xlUp).Row
    ReDim inputt(1 To TotalRows)
    For i = 1 To TotalRows
        inputt(i) = Cells(i, 1).Value
    Next
    outputt = Split(ListSubsets(inputt), vbCrLf)
    For i = 2 To (2 ^ TotalRows)
        Cells(i - 1, 2).Value = outputt(i)
    Next i
End Sub


Function ListSubsets(Items As Variant) As String
    Dim CodeVector() As Long
    Dim i As Long
    Dim lower As Long, upper As Long
    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

 

[Juizt]

Welcome to the Forum!

Assuming there are no duplicate words that you want to suppress, you can generate combinations using the formula below.

The formula can accommodate up to 20 words, in which case you'd need the entire column to display results. For 25 words there are >33 million combinations i.e. 2^25-1.

But why do you need to list all the possibilities? You can carry out any analysis you like using combinatorial formulae, without needing to count the individual possibilities.

	A	B	C	D	E
1
2		A	B	C	D
3
4
5		A
6		B
7		A B
8		C
9		A C
10		B C
11		A B C
12		D
13		A D
14		B D
15		A B D
16		C D
17		A C D
18		B C D
19		A B C D
20
Sheet1

Cell Formulas
Range	Formula
B4:B19	B4	=LET(words,B2:E2,N,COUNTA(words), BYROW(IF(INT(MOD(SEQUENCE(2^N,,0)/2^SEQUENCE(,N,0),2)),words,""),LAMBDA(r,TEXTJOIN(" ",,r))))
Dynamic array formulas.

Thank you very much, this is usable.

 

[Juizt]

I guess it is not achievable with formulas. Assuming your letters are from A1:A3, a fast solution can be:

Sub TestRoutine()
    Dim inputt() As Variant, i As Long
    Dim outputt As Variant
    TotalRows = Rows(Rows.Count).End(xlUp).Row
    ReDim inputt(1 To TotalRows)
    For i = 1 To TotalRows
        inputt(i) = Cells(i, 1).Value
    Next
    outputt = Split(ListSubsets(inputt), vbCrLf)
    For i = 2 To (2 ^ TotalRows)
        Cells(i - 1, 2).Value = outputt(i)
    Next i
End Sub


Function ListSubsets(Items As Variant) As String
    Dim CodeVector() As Long
    Dim i As Long
    Dim lower As Long, upper As Long
    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

This does exactly what I asked for and i will probably end up going with this solution. Thank you very much.

 

[Legacy 143009]

Thanks for the feedback

 

[Legacy 143009]

Here is a much cleaner code using @Fluff 's algorithm:

Sub permutation()
  
  Dim lRow As Integer
  lRow = Cells(Rows.Count, 1).End(xlUp).Row
  ReDim inputt(lRow) As String
  ReDim outputt((2 ^ lRow) - 1) As String
    Dim iii As Long
  iii = 0
  
  For i = 1 To lRow
    inputt(i - 1) = Cells(i, 1).Value
  Next

  For i = 0 To lRow - 1
    outputt(iii) = inputt(i)
    For ii = 0 To iii - 1
    iii = iii + 1
      outputt(iii) = outputt(ii) & inputt(i)
    Next
    iii = iii + 1
  Next
  
  Application.ScreenUpdating = False
  For i = 1 To (2 ^ lRow) - 1
     Cells(i, 2).Value = outputt(i - 1)
  Next
  Application.ScreenUpdating = True
  
End Sub

@Fluff I got a question for you. Is there anyway to express output index in terms of i or ii without need of iii? Is there a mathematical formula for this?