Get all combinations without repetition

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Get all combinations without repetition

Post by YasserKhalil »

Hello everyone
Suppose I have the values 1, 2, 3 in range("A1:A3") and I have the following code to get all the combinations of those values

Code: Select all

Sub Test()
    Dim a, b(1 To 1000), i As Long, ii As Long, k As Long
    a = Range("A1").CurrentRegion.Value
    For i = LBound(a) To UBound(a)
        For ii = LBound(a) To UBound(a)
            If a(i, 1) = a(ii, 1) Then
                k = k + 1
                b(k) = a(i, 1)
            Else
                k = k + 1
                b(k) = a(i, 1) & a(ii, 1)
            End If
        Next ii
    Next i
    Range("C1").Resize(UBound(b)).Value = Application.Transpose(b)
End Sub
What I got is like that
1.png
But I need to exclude the repetition (I mean 12 and 21 is the same as those two results have the same output) and the order is not important. so I expect the output to be like that
2.png
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Get all combinations without repetition

Post by HansV »

See Return all combinations. You should be able to adapt it for your purpose.
Best wishes,
Hans

User avatar
rory
5StarLounger
Posts: 817
Joined: 24 Jan 2010, 15:56

Re: Get all combinations without repetition

Post by rory »

Already answered on SO here: https://stackoverflow.com/questions/670 ... repetition

(though the question has been deleted now for some reason)
Regards,
Rory

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Get all combinations without repetition

Post by YasserKhalil »

The question is marked as a duplicate thread. I would like to modify on the code I have put in the main question if possible.

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Get all combinations without repetition

Post by Doc.AElstein »

HelloYasser
I can’t figure out what’s going on in any of the previous referenced stuff – I can’t easily figure out the logic. I’m too stupid for that stuff…

I can think of an easy way to modify, or rather add to a solution , to possibly get the results wanted

For example, take that solution in the original as you say gave in the main question if possible …_
_...Before your b() array is filled, it could be checked to see if a sorted version of the character combination just obtained is already held. If it isn’t then only then Take That
I haven’t tested those solutions thoroughly but they seem to give something like you want. ( They don’t return you the full string, ( 123 in your example ) , but neither does your main question macro. ( I am sure you can add a bit to include that ). )

I expect that isn’t a good solution because you are doing something, and then correcting for the bits you have done which you don’t want. ( Having said that, something like Sub Take3() and Sub Take4() is a bit better )
I expect it is more efficient to tackle the problem in a more fundamental way, but that sort of better solution is beyond my ability, or I would need a week for me to figure out what’s going on to such an extent that I could modify to get a better more fundamental solution… Possibly it might need a good Maths brain , which mine isn’t at the best of times…

Alan

_.____________________________________________________________________________________________

Edit P.S.
Just to clarify, as I have been editing….
I have 4 macro offerings:
Sub TakeThat1() and Sub TakeThat2()
https://excelfox.com/forum/showthread.p ... #post15512


Sub Take3() and Sub Take4()
https://excelfox.com/forum/showthread.p ... #post15513



Also, all macros need the Function BubSrt ( )
https://excelfox.com/forum/showthread.p ... #post15514



also all is in the uploaded file
You do not have the required permissions to view the files attached to this post.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Get all combinations without repetition

Post by YasserKhalil »

Thanks a lot Mr. Alan
As for the results should have 123 too.

Another example to make it clearer
1
2
3
4

The expected output would be
1
1,2
2
2,3
1,2,3
1,3
3
3,4
1,3,4
1,2,3,4
2,3,4
2,4
1,2,4
1,4
4

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Get all combinations without repetition

Post by YasserKhalil »

Here's a code that gives the results but when dealing with about 60 numbers, it doesn't work and excel hangs

Code: Select all

Sub Test_GrayCode_UDF()
    Dim b
    b = Convert2DArrayTo1DArray(Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value)
    Call GrayCode(b)
End Sub

Function Convert2DArrayTo1DArray(arr As Variant)
    Dim b(), i As Long
    ReDim b(1 To UBound(arr, 1))
    For i = 1 To UBound(arr, 1)
        b(i) = arr(i, 1)
    Next i
    Convert2DArrayTo1DArray = b
End Function

Function GrayCode(Items) As String
    Dim v() As Long, f As Boolean, b As Boolean, subList As String, newSub As String, i As Long, k As Long, lower As Long, upper As Long
    k = 0: b = True
    lower = LBound(Items): upper = UBound(Items)
    ReDim v(lower To upper)
    Do Until f
        newSub = ""
        For i = lower To upper
            If v(i) = 1 Then
                If newSub = "" Then newSub = "," & Items(i) Else newSub = newSub & "," & Items(i)
            End If
        Next i
        subList = subList & vbCrLf & newSub
        If newSub <> "" Then
            k = k + 1
            Cells(k, 3) = Mid(newSub, 2)
        End If
        If b Then
            v(lower) = 1 - v(lower)
        Else
            i = lower
            Do While v(i) <> 1
                i = i + 1
            Loop
            If i = upper Then f = True Else i = i + 1: v(i) = 1 - v(i)
        End If
        b = Not b
    Loop
    GrayCode = subList
End Function

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Get all combinations without repetition

Post by HansV »

The number of combinations of 60 items is a number with 19 digits - far too large to handle.
If you want to fit the results in one column, the maximum number of items is 20 - the number of combinations would be 1048575, one less than the number of rows in a column.
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Get all combinations without repetition

Post by YasserKhalil »

Thanks a lot for reply, my tutor. How did you calculate the number of the expected results?

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Get all combinations without repetition

Post by YasserKhalil »

Can this be handled using arrays and export the results to a text file instead of writing them to the excel file?

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Get all combinations without repetition

Post by HansV »

The number of combinations of n items is 2^n - 1.

S0307.png

Because the number grows exponentially, it soon becomes extremely large. for 40 items it is 1099511627775. It would take a very long time and the resulting file would be a terabyte or so - not really practical.
You do not have the required permissions to view the files attached to this post.
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Get all combinations without repetition

Post by YasserKhalil »

Thanks a lot, my tutor.
I would deal with 20 numbers. Can the code be improved to be quicker?

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Get all combinations without repetition

Post by HansV »

Try this. For n = 20, it takes between 6 and 7 seconds on my PC.

Code: Select all

Sub Test()
    Dim n As Long
    Range("A:A").ClearContents
    n = 20
    Call GenerateCombinations(n)
End Sub

Sub GenerateCombinations(n As Long)
    Dim i As Long
    Dim m As Long
    Dim j As Long
    Dim s As String
    If n > 20 Then
        MsgBox "Cannot process more than 20 items!", vbExclamation
        Exit Sub
    End If
    m = 2 ^ n - 1
    ReDim a(1 To m, 1 To 1) As String
    For i = 1 To m
        s = ""
        For j = 1 To n
            If i And 2 ^ (j - 1) Then
                s = s & "," & j
            End If
        Next j
        a(i, 1) = Mid(s, 2)
    Next i
    Range("A1").Resize(m).Value = a
End Sub
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Get all combinations without repetition

Post by YasserKhalil »

Really amazing my tutor.
How can I change the code so as to specify the range where the numbers will be as the numbers would be different numbers not from 1 o 20?
the numbers could be like that:
17
96
32
1
25
14
13
12
and so on.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Get all combinations without repetition

Post by HansV »

Here is a new version.
The first argument of GenerateCombinations is now the source range. Only its first column will be used. This may contain text values or number values.
The second argument specifies the top cell of the results. Its entire column will be cleared first.

Code: Select all

Sub Test()
    Call GenerateCombinations(Range("A1:A5"), Range("B1"))
End Sub

Sub GenerateCombinations(rng As Range, target As Range)
    Dim n As Long
    Dim v As Variant
    Dim i As Long
    Dim m As Long
    Dim j As Long
    Dim s As String
    n = rng.Count
    If n > 20 Then
        MsgBox "Cannot process more than 20 items!", vbExclamation
        Exit Sub
    End If
    v = rng.Columns(1).Value
    m = 2 ^ n - 1
    ReDim a(1 To m, 1 To 1) As String
    For i = 1 To m
        s = ""
        For j = 1 To n
            If i And 2 ^ (j - 1) Then
                s = s & "," & v(j, 1)
            End If
        Next j
        a(i, 1) = Mid(s, 2)
    Next i
    target(1).EntireColumn.ClearContents
    target(1).Resize(m).Value = a
End Sub
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Get all combinations without repetition

Post by YasserKhalil »

Thank you very much for these amazing solutions.

User avatar
Doc.AElstein
BronzeLounger
Posts: 1499
Joined: 28 Feb 2015, 13:11
Location: Hof, Bayern, Germany

Re: Get all combinations without repetition

Post by Doc.AElstein »

Hello Yasser
I see you have plenty of solutions in the meantime, but just to answer this last small point…
YasserKhalil wrote:
17 Apr 2021, 21:11
... the results should have 123 too.
… I mentioned about that already here …. ( They don’t return you the full string, ( 123 in your example ) , but neither does your main question macro. ( I am sure you can add a bit to include that ). ...................)

I did not do the modifications myself, as I thought you could think of a way to do all that.

For example in Sub Take3() , you would just add a line to include the full concatenated range number to the dictionary.
To get a concatenation, one way could be to convert the range to a 1 D array ( example by transposing ) , then Join it with no separator, something like
Dik.Add Key:=Join(Application.Transpose(Your range, ""), …….

Alan

Example applied to my Sub Take3()

Code: Select all

Sub Take3b()   '    https://eileenslounge.com/viewtopic.php?p=283095#p283095
Rem 1 data
Dim Ay() As Variant
Dim Eye As Long, AyeAye As Long, Kay As Long
 Let Ay() = Range("Q1").CurrentRegion.Value2
Rem 2 Do It
Dim Dik As Object: Set Dik = CreateObject("Scripting.Dictionary")
    For Eye = LBound(Ay(), 1) To UBound(Ay(), 1)
        For AyeAye = LBound(Ay(), 1) To UBound(Ay(), 1)
         If Ay(Eye, 1) = Ay(AyeAye, 1) Then
          Let Kay = Kay + 1
          'Let Bea(Kay) = Ay(Eye, 1)
            If Not Dik.exists(BubSrt(Ay(Eye, 1))) Then Dik.Add Key:=Ay(Eye, 1), Item:="AnyThong"
         Else
          Let Kay = Kay + 1
          'Let Bea(Kay) = Ay(Eye, 1) & Ay(AyeAye, 1)
            If Not Dik.exists(BubSrt(Ay(Eye, 1) & Ay(AyeAye, 1))) Then Dik.Add Key:=Ay(Eye, 1) & Ay(AyeAye, 1), Item:="AnyThong"
         End If
        Next AyeAye
    Next Eye
 'Dik.Add Key:=Join(Application.Transpose(Range("Q1").CurrentRegion.Value2), ""), Item:="AnyThong"
 Dik.Add Key:=Join(Application.Index(Range("Q1").CurrentRegion.Value2, Evaluate("=Column(A:" & CL(UBound(Range("Q1").CurrentRegion.Value2, 1)) & ")"), Evaluate("=Column(A:" & CL(UBound(Range("Q1").CurrentRegion.Value2, 1)) & ")/Column(A:" & CL(UBound(Range("Q1").CurrentRegion.Value2, 1)) & ")")), ""), Item:="AnyThong"
 Dim UnicBea() As Variant: Let UnicBea() = Dik.Keys()

Rem 3 Output
 Range("S1:T20").ClearContents
 Let Range("T1").Resize(UBound(UnicBea()) + 1, 1).Value2 = Application.Transpose(UnicBea())
 Let Range("T1").Resize(UBound(UnicBea()) + 1, 1).Value2 = Application.Index(UnicBea(), Evaluate("=row(1:" & UBound(UnicBea()) + 1 & ")/row(1:" & UBound(UnicBea()) + 1 & ")"), Evaluate("=row(1:" & UBound(UnicBea()) + 1 & ")"))
End Sub







Function BubSrt(ByVal Thong As String) As String
Dim Buf() As String: Let Buf() = Split(StrConv(Thong, vbUnicode), Chr$(0)): ReDim Preserve Buf(UBound(Buf()) - 1) '  https://stackoverflow.com/questions/13195583/split-string-into-array-of-characters
Dim Ey As Long, Jay As Long
Dim Temp As Long
 For Ey = LBound(Buf()) To UBound(Buf()) - 1
    For Jay = Ey + 1 To UBound(Buf())
        If Buf(Ey) > Buf(Jay) Then
         Let Temp = Buf(Jay)
         Let Buf(Jay) = Buf(Ey)
         Let Buf(Ey) = Temp
        End If
    Next Jay
Next Ey
 Let BubSrt = Join(Buf(), "")
End Function

Public Function CL(ByVal lclm As Long) As String '         http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
    Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function


Sub transposWonks()
Dim vTemp As Variant, vTempT As Variant
 Let vTemp = Range("Q1").CurrentRegion.Value2
 Let vTempT = Application.Transpose(vTemp)
 Let vTempT = Application.Index(vTemp, Evaluate("=Column(A:C)"), Evaluate("=Column(A:C)/Column(A:C)"))
 Let vTempT = Application.Index(vTemp, Evaluate("=Column(A:" & CL(UBound(vTemp, 1)) & ")"), Evaluate("=Column(A:" & CL(UBound(vTemp, 1)) & ")/Column(A:" & CL(UBound(vTemp, 1)) & ")"))
 Let vTempT = Application.Index(Range("Q1").CurrentRegion.Value2, Evaluate("=Column(A:" & CL(UBound(Range("Q1").CurrentRegion.Value2, 1)) & ")"), Evaluate("=Column(A:" & CL(UBound(Range("Q1").CurrentRegion.Value2, 1)) & ")/Column(A:" & CL(UBound(Range("Q1").CurrentRegion.Value2, 1)) & ")"))
End Sub
You do not have the required permissions to view the files attached to this post.
I am having difficulty logging in with this account just now.
You can find me at DocAElstein also

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Get all combinations without repetition

Post by YasserKhalil »

Thanks a lot Mr. Alan for your great efforts.