Combinations with restricted repetitions

[Joige]

Hello, I have a list of items that I want to make all possible combinations with, but the number of times each ingredient is used is restricted by the quantity owned. Order of ingredients does not matter.
Bellow is an example:

Book1
	B	C	D	E	F	G	H
2	Fruit	Quantity		Fruit 1	Fruit 2	Fruit 3	Fruit 4
3	Strawberry	5		Strawberry	Strawberry	Strawberry	Strawberry
4	Apple	1		Strawberry	Strawberry	Strawberry	Apple
5	Banana	3		Strawberry	Strawberry	Strawberry	Banana
6				Strawberry	Strawberry	Apple	Banana
7				Strawberry	Strawberry	Banana	Banana
8				Strawberry	Apple	Banana	Banana
9				Strawberry	Banana	Banana	Banana
10				Apple	Banana	Banana	Banana
Sheet1

Thanks in advance!

 

[Joige]

I want to make all possible combinations

Forgot to mention that I only want combinations of 4 ingredients.

 

[Eric W]

Open a COPY of your workbook. Press Alt-F11 to open the VBA editor. Press Alt-IM to Insert a Module. Paste the following code in the sheet that opens:

Sub FruitSalad()
Dim MaxCols As Long, mydata As Variant, ctr As Long, maxcnt As Long, i As Long, Bowl() As Variant

    MaxCols = 4
    mydata = Range("B3:C" & Range("B10000").End(xlUp).Row).Value
    
    Set dic = CreateObject("Scripting.Dictionary")
    str1 = ""
    For i = 1 To MaxCols
        str1 = str1 & "Fruit " & i & "|"
    Next i
    dic(str1) = 1
    
    maxcnt = 0
    ctr = 1
    For i = 1 To UBound(mydata)
        maxcnt = maxcnt + IIf(mydata(i, 2) > MaxCols, MaxCols, mydata(i, 2))
        ReDim Preserve Bowl(0 To maxcnt)
        For j = ctr To maxcnt
            Bowl(j) = i
        Next j
        ctr = j
    Next i
    
    Call TossIt(Bowl, 0, MaxCols, 0, "", dic, mydata)
    
    Range("E1").Resize(Rows.Count, MaxCols).ClearContents
    Range("E2").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
    Range("E:E").TextToColumns , DataType:=xlDelimited, Other:=True, OtherChar:="|"
    
    
End Sub

Sub TossIt(ByRef fruits, ByVal CurDepth, ByRef MaxDepth, ByVal ix, ByVal answer, ByRef dic, ByRef mydata)
Dim i As Long, wk As Variant, res As String

    If CurDepth = MaxDepth Then
        wk = Split(answer, ",")
        res = ""
        For i = 0 To MaxDepth - 1
            res = res & mydata(fruits(wk(i)), 1) & "|"
        Next i
        dic(res) = dic(res) + 1
        Exit Sub
    End If
    
    For i = ix + 1 To UBound(fruits)
        Call TossIt(fruits, CurDepth + 1, MaxDepth, i, answer & i & ",", dic, mydata)
    Next i

End Sub

Change the MaxCols value on the first line to the number of columns you want. Change the B3:C on the next line to the top row where your table is. Change the Range("E1") near the end of the first procedure to the column where you want the results. Change the next 2 lines similarly.

Press Alt-Q to close the VBA editor. Set up your sheet as you did in the first post. Press Alt-F8 to open the Macro Selector. Select FruitSalad and click Run.

Let us know how it works!

 

[Joige]

Open a COPY of your workbook. Press Alt-F11 to open the VBA editor. Press Alt-IM to Insert a Module. Paste the following code in the sheet that opens:

Change the MaxCols value on the first line to the number of columns you want. Change the B3:C on the next line to the top row where your table is. Change the Range("E1") near the end of the first procedure to the column where you want the results. Change the next 2 lines similarly.

Press Alt-Q to close the VBA editor. Set up your sheet as you did in the first post. Press Alt-F8 to open the Macro Selector. Select FruitSalad and click Run.

Let us know how it works!

This is amazing!
From a person that doesn't know how to code and never used VBA, your instructions and the clarity of the code made it easy for me to use it and change whatever I needed!

Thank you so much!

 

[Joige]

Just one more question:
When I use the macro, it seems to clear 5 columns instead of the 4 it uses, anyway to change that?

 

[Eric W]

Try this:

Sub FruitSalad()
Dim MaxCols As Long, mydata As Variant, ctr As Long, maxcnt As Long, i As Long, Bowl() As Variant

    MaxCols = 4
    mydata = Range("B3:C" & Range("B10000").End(xlUp).Row).Value
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic("Fruit 1|Fruit 2|Fruit 3|Fruit 4") = 1
    
    maxcnt = 0
    ctr = 1
    For i = 1 To UBound(mydata)
        maxcnt = maxcnt + IIf(mydata(i, 2) > MaxCols, MaxCols, mydata(i, 2))
        ReDim Preserve Bowl(0 To maxcnt)
        For j = ctr To maxcnt
            Bowl(j) = mydata(i, 1)
        Next j
        ctr = j
    Next i
    
    Call TossIt(Bowl, 0, MaxCols, 0, "", dic)
    
    Range("E1").Resize(Rows.Count, MaxCols).ClearContents
    Range("E2").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
    Range("E:E").TextToColumns , DataType:=xlDelimited, Other:=True, OtherChar:="|"
    
    
End Sub

Sub TossIt(ByRef fruits, ByVal CurDepth, ByRef MaxDepth, ByVal ix, ByVal answer, ByRef dic)
Dim i As Long

    If CurDepth = MaxDepth Then
        dic(answer) = 1
        Exit Sub
    End If
    
    For i = ix + 1 To UBound(fruits)
        Call TossIt(fruits, CurDepth + 1, MaxDepth, i, answer & fruits(i) & IIf(CurDepth + 1 = MaxDepth, "", "|"), dic)
    Next i

End Sub

I thought of a few ways to shorten it a bit as well. You can see at the top of the first routine where I put the headings.

 

[Joige]

That Fixed it! Thanks!

This might be too much, but is there a way to only show combinations that use specific fruits?
For example, I can write a 1 or a 0 on column D, 1 means that at least one fruit of these is used in the combinations.

Book1
	B	C	D	E	F	G	H
2	Fruit	Quantity	At least 1	Fruit 1	Fruit 2	Fruit 3	Fruit 4
3	Strawberry	5	1	Strawberry	Strawberry	Strawberry	Banana
4	Apple	1	0	Strawberry	Strawberry	Apple	Banana
5	Banana	3	1	Strawberry	Strawberry	Banana	Banana
6				Strawberry	Apple	Banana	Banana
7				Strawberry	Banana	Banana	Banana
Sheet1

If this is too much, I can use a variation of the one you have now, you have already helped immensely, Thanks!

 

[Eric W]

You could just set the quantity to 0 on that row. But if you want to add your D column:

Sub FruitSalad()
Dim MaxCols As Long, mydata As Variant, ctr As Long, maxcnt As Long, i As Long, Bowl() As Variant

    MaxCols = 4
    mydata = Range("B3:D" & Range("B10000").End(xlUp).Row).Value
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic("Fruit 1|Fruit 2|Fruit 3|Fruit 4") = 1
    
    maxcnt = 0
    ctr = 1
    For i = 1 To UBound(mydata)
        If mydata(i, 3) = 0 Then mydata(i, 2) = 0
        maxcnt = maxcnt + IIf(mydata(i, 2) > MaxCols, MaxCols, mydata(i, 2))
        ReDim Preserve Bowl(0 To maxcnt)
        For j = ctr To maxcnt
            Bowl(j) = mydata(i, 1)
        Next j
        ctr = j
    Next i
    
    Call TossIt(Bowl, 0, MaxCols, 0, "", dic)
    
    Range("E1").Resize(Rows.Count, MaxCols).ClearContents
    Range("E2").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
    Range("E:E").TextToColumns , DataType:=xlDelimited, Other:=True, OtherChar:="|"
    
End Sub

Sub TossIt(ByRef fruits, ByVal CurDepth, ByRef MaxDepth, ByVal ix, ByVal answer, ByRef dic)
Dim i As Long

    If CurDepth = MaxDepth Then
        dic(answer) = 1
        Exit Sub
    End If
    
    For i = ix + 1 To UBound(fruits)
        Call TossIt(fruits, CurDepth + 1, MaxDepth, i, answer & fruits(i) & IIf(CurDepth + 1 = MaxDepth, "", "|"), dic)
    Next i

End Sub

Just change the C to a D in the second line of code, and add the line in red a little further down.

 

[Joige]

You could just set the quantity to 0 on that row. But if you want to add your D column:

Just change the C to a D in the second line of code, and add the line in red a little further down

Sorry, I think you didn't understand what I meant.
I still want to use the fruits that have a 0 on column D, but the fruits that have a 1 on column D, have to be present in all combinations.
Just like a filter that only shows the combinations with the fruits that have 1 on column D.

 

[Eric W]

Give this a whirl:

Sub FruitSalad()
Dim MaxCols As Long, MyData As Variant, ctr As Long, maxcnt As Long, i As Long, Bowl() As Variant

    MaxCols = 4
    MyData = Range("B3:D" & Range("B10000").End(xlUp).Row).Value
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic("Fruit 1|Fruit 2|Fruit 3|Fruit 4") = 1
    
    maxcnt = 0
    ctr = 1
    For i = 1 To UBound(MyData)
        maxcnt = maxcnt + IIf(MyData(i, 2) > MaxCols, MaxCols, MyData(i, 2))
        ReDim Preserve Bowl(0 To maxcnt)
        For j = ctr To maxcnt
            Bowl(j) = MyData(i, 1)
        Next j
        ctr = j
    Next i
    
    Call TossIt(Bowl, 0, MaxCols, 0, "", dic, MyData)
    
    Range("E1").Resize(Rows.Count, MaxCols).ClearContents
    Range("E2").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
    Range("E:E").TextToColumns , DataType:=xlDelimited, Other:=True, OtherChar:="|"
    
    
End Sub

Sub TossIt(ByRef fruits, ByVal CurDepth, ByRef MaxDepth, ByVal ix, ByVal answer, ByRef dic, ByRef MyData)
Dim i As Long

    If CurDepth = MaxDepth Then
        For i = 1 To UBound(MyData)
            If MyData(i, 3) = 1 Then
                If InStr(answer, MyData(i, 1)) = 0 Then Exit Sub
            End If
        Next i
        dic(answer) = 1
        Exit Sub
    End If
    
    For i = ix + 1 To UBound(fruits)
        Call TossIt(fruits, CurDepth + 1, MaxDepth, i, answer & fruits(i) & IIf(CurDepth + 1 = MaxDepth, "", "|"), dic, MyData)
    Next i

End Sub