Generate all combinations with SUM restriction

[SidKol]

Hi all,

I can do some basic VBA and would love to fix this myself, but I just can't (yet)
I believe it requires some real Excel wizard master.

So here is the thing:

I have tracked down a wonderful macro (I think it was originally created by member shg)

This macro generates all possible combinations from input by a single click
For example:

It works truly fantastic.
However for me personally the limitation to 1 million rows is an obstacle.

Therefore I tried to add a condition that will not allow every combination to be listed.
This code however is so complex to me... just can't find anything even near a solution.

So what I want to add is a check that involves a list of values on sheet "Value"

[TABLE="class: grid, width: 500, align: center"]
<tbody>[TR]
[TD]Option Name[/TD]
[TD]Value[/TD]
[/TR]
[TR]
[TD]Option A - 1[/TD]
[TD]7[/TD]
[/TR]
[TR]
[TD]Option B - 1[/TD]
[TD]8[/TD]
[/TR]
[TR]
[TD]Option C - 1[/TD]
[TD]9[/TD]
[/TR]
[TR]
[TD]Option C - 2[/TD]
[TD]10[/TD]
[/TR]
[TR]
[TD]Option D - 1[/TD]
[TD]11[/TD]
[/TR]
[TR]
[TD]Option E - 1[/TD]
[TD]12[/TD]
[/TR]
[TR]
[TD]Option E - 2[/TD]
[TD]13[/TD]
[/TR]
[TR]
[TD]Option E - 3[/TD]
[TD]14[/TD]
[/TR]
[TR]
[TD]Option E - 4[/TD]
[TD]15[/TD]
[/TR]
[TR]
[TD]Option F - 1[/TD]
[TD]16[/TD]
[/TR]
[TR]
[TD]Option G - 1[/TD]
[TD]17[/TD]
[/TR]
[TR]
[TD]Option G - 2[/TD]
[TD]18[/TD]
[/TR]
[TR]
[TD]Option G - 3[/TD]
[TD]19[/TD]
[/TR]
[TR]
[TD]Option G - 4[/TD]
[TD]20[/TD]
[/TR]
[TR]
[TD]Option G - 5[/TD]
[TD]21[/TD]
[/TR]
[TR]
[TD]Option G - 6[/TD]
[TD]22[/TD]
[/TR]
</tbody>[/TABLE]


The VBA should list only combinations of which the combined (SUM) value is not exceeding 85.

In fact I have more limitations in mind to narrow things down, but just this one should be able to set me off to create so much more.


This is the original code created by shg:

Option Explicit


Const sTitle        As String = "shg Cartesian Product"



Sub CartesianProduct()    ' shg 2012, 2013
    ' Choose one from col A, one from col B, ...


    Dim rInp        As Range
    Dim avInp       As Variant  ' ragged input list
    Dim nCol        As Long     ' # columns in list
    Dim rOut        As Range    ' output range
    Dim iCol        As Long     ' column index
    Dim iRow        As Long     ' row index
    Dim aiCum()     As Long     ' cum count of arrangements from right to left
    Dim aiCnt()     As Long     ' count of items in each column
    Dim iArr        As Long     ' arrangement number
    Dim avOut       As Variant  ' output buffer


    Application.ScreenUpdating = False


    Set rInp = Range("rgnInp")
    If VarType(rInp.Value) = vbEmpty Then
        MsgBox Prompt:="No input!", _
               Buttons:=vbOKOnly, _
               Title:=sTitle
        Exit Sub
    End If


    Set rInp = rInp.CurrentRegion
    If rInp.Columns.Count < 2 Or rInp.Rows.Count < 2 Then
        MsgBox Prompt:="Must have more than one row and more than one columns!", _
               Buttons:=vbOKOnly, _
               Title:=sTitle
        Exit Sub
    End If


    With rInp
        .Style = "Input"
        avInp = .Value
        nCol = .Columns.Count
        Set rOut = .Resize(1).Offset(.Rows.Count + 1)
        Range(rOut.Offset(-1, -1), Cells(Rows.Count, Columns.Count)).Clear
    End With


    ReDim aiCum(1 To nCol + 1)
    ReDim aiCnt(1 To nCol)
    aiCum(nCol + 1) = 1




    For iCol = nCol To 1 Step -1
        For iRow = 1 To UBound(avInp, 1)
            If IsEmpty(avInp(iRow, iCol)) Then Exit For
            aiCnt(iCol) = aiCnt(iCol) + 1
        Next iRow


        aiCum(iCol) = aiCnt(iCol) * aiCum(iCol + 1)
    Next iCol


    If aiCum(1) > Rows.Count - rOut.Row + 1 Then
        MsgBox Prompt:=Format(aiCum(1), "#,##0") & _
                       " is too many rows!", _
               Buttons:=vbOKOnly, Title:=sTitle
        Exit Sub
    End If


    ReDim avOut(1 To aiCum(1), 1 To nCol)
    For iArr = 1 To aiCum(1)
        For iCol = 1 To nCol
            avOut(iArr, iCol) = avInp((Int((iArr - 1) * aiCnt(iCol) / aiCum(iCol))) Mod aiCnt(iCol) + 1, iCol)
        Next iCol
    Next iArr


    With rOut.Resize(aiCum(1), nCol)
        .NumberFormat = "@"
        .Value = avOut
        .Style = "Code"
        .Cells(1, 0).Value = 1
        .Cells(2, 0).Value = 2
        .Cells(1, 0).Resize(2).AutoFill .Columns(0)
    End With


    ActiveWindow.FreezePanes = False
    rOut.EntireColumn.AutoFit
    ActiveSheet.UsedRange
    Beep
End Sub

So hopefully any of you is willing to help me out on this.

thank you very much in advance!! All help greatly appreciated

 

[SidKol]

In case any of you may be wondering what i tried myself,

Until now I think that right after filling a new row there should be a SUM-formula

For iArr = 1 To aiCum(1)        For iCol = 1 To nCol
            avOut(iArr, iCol) = avInp((Int((iArr - 1) * aiCnt(iCol) / aiCum(iCol))) Mod aiCnt(iCol) + 1, iCol)
'move 1 cell to right and add formula that sums the cells before (=SUM(XXXXX)

After this following should be executed:

If .Value > Range("XXXXX").Value Then
            '.EntireRow.Delete

I find it very hard to assign the variable ranges in an iteration for this, for that I marked those values with XXXXX

 

[StephenCrump]

Try these code modifications. I have assumed rngValues: =J1:P6

The results shown for illustration purposes only are for MY_MAX=82. Just change appropriately.

'Extra declarations and initialisation
Dim avValues    As Variant
Dim lTotal      As Long
Dim lCount      As Long
Dim lRow        As Long
Const MY_MAX = 82

avValues = Range("rngValues").Value
lCount = 1

'....

'near the end of existing code:
For iArr = 1 To aiCum(1)
    lTotal = 0
    For iCol = 1 To nCol
        lRow = (Int((iArr - 1) * aiCnt(iCol) / aiCum(iCol))) Mod aiCnt(iCol) + 1
        avOut(lCount, iCol) = avInp(lRow, iCol)
        lTotal = lTotal + avValues(lRow, iCol)
        If lTotal > MY_MAX Then Exit For
    Next iCol
    If iCol = nCol + 1 Then lCount = lCount + 1
Next iArr

If lCount = 1 Then
    MsgBox "No values found!"
Else
    With rOut.Resize(lCount - 1, nCol)
        .NumberFormat = "@"
        .Value = avOut
        '.Style = "Code"
        .Cells(1, 0).Value = 1
        .Cells(2, 0).Value = 2
        .Cells(1, 0).Resize(2).AutoFill .Columns(0)
    End With
End If

Excel 2010
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1		A1	B1	C1	D1	E1	F1	G1		7	8	9	11	12	16	17
2				C2		E2		G2				10		13		18
3						E3		G3				11		14		19
4						E4		G4				12		15		20
5								G5								21
6								G6								22
7
8	1	A1	B1	C1	D1	E1	F1	G1
9	2	A1	B1	C1	D1	E1	F1	G2
10	3	A1	B1	C1	D1	E1	F1	G3
11	4	A1	B1	C1	D1	E2	F1	G1
12	5	A1	B1	C1	D1	E2	F1	G2
13	6	A1	B1	C1	D1	E3	F1	G1
14	7	A1	B1	C2	D1	E1	F1	G1
15	8	A1	B1	C2	D1	E1	F1	G2
16	9	A1	B1	C2	D1	E2	F1	G1
Sheet1

 

[SidKol]

Thank you so much Stephen.
It works perfect!

I have even already been able to play around with it to add a second restriction based on additional information.

Love this kind of toying around with Excel.
Thank you so much for helping me out so I can continue playing with it!

 

[SidKol]

While playing around I found out the following:

If I change > to < in

"If lTotal [COLOR=#0000ff]>[/COLOR] MY_MAX Then Exit For

I always get the MsgBox "No values found!"

Does anybody know why this happens?
Doest

For iArr = 1 To aiCum(1)
    lTotal = 0
    For iCol = 1 To nCol
        lRow = (Int((iArr - 1) * aiCnt(iCol) / aiCum(iCol))) Mod aiCnt(iCol) + 1
        avOut([COLOR=#0000ff]lCount[/COLOR], iCol) = avInp(lRow, iCol)
        lTotal = lTotal + avValues(lRow, iCol)
[COLOR=#0000ff]        If lTotal > MY_MAX Then Exit For[/COLOR]
    Next iCol
    If iCol = nCol + 1 Then [COLOR=#0000ff]lCount[/COLOR] = [COLOR=#0000ff]lCount + 1[/COLOR]
Next iArr


[COLOR=#0000ff]If lCount = 1 Then[/COLOR]
[COLOR=#0000ff]    MsgBox "No values found!"[/COLOR]

 

[StephenCrump]

For iArr = 1 To aiCum(1)
    lTotal = 0
    For iCol = 1 To nCol
        lRow = (Int((iArr - 1) * aiCnt(iCol) / aiCum(iCol))) Mod aiCnt(iCol) + 1
        avOut(lCount, iCol) = avInp(lRow, iCol)
        lTotal = lTotal + avValues(lRow, iCol)
        If lTotal > MY_MAX Then Exit For
    Next iCol
    If iCol = nCol + 1 Then lCount = lCount + 1
Next iArr

In the block of code above, lTotal is a cumulative sum, adding successively across the columns. As soon as we exceed the specified maximum, we need go no further, and can exit the loop. For example, for combination A1,B1,C2,D1,E4,F1,G6 and a specified MY_MAX of 66, say, we have lTotal = 7+8+10+11+15+16+22, which is already 67 by the time we count F1, hence we don't need to bother adding G6, and we can exit the loop.

If you reverse the sign, and have:

If lTotal [COLOR=#ff0000][B]<[/B][/COLOR] MY_MAX Then Exit For

then in the first iteration of the loop you'll have lTotal=7 (i.e. equal to A1) and the loop will terminate.

If you want to show only the combinations with sums not less than some specified value MY_MIN, you could modify the loop this way:

For iArr = 1 To aiCum(1)
    lTotal = 0
    For iCol = 1 To nCol
        lRow = (Int((iArr - 1) * aiCnt(iCol) / aiCum(iCol))) Mod aiCnt(iCol) + 1
        avOut(lCount, iCol) = avInp(lRow, iCol)
        lTotal = lTotal + avValues(lRow, iCol)
    Next iCol
    If lTotal >= MY_MIN Then lCount = lCount + 1
Next iArr

 

[SidKol]

Thank you again for explaining this in a very understandable way!

I knew it had to be happening right at the start of executing the loop, tried a lot of things but never thought of replacing that part.

Actually managed to create a "dirty" workaround by deducting actual values from 100 (So 20 as a value became 80, 21 became 79 and so on.)
Additionally I changed MY_MAX to 718. (8*100 - original MY_MAX)
This way I could continue using the > instead of < when still hitting only results with a combined value of less than 82.

Ofcourse your fix is way better
Thanks for that.

Actually (after disabling the popup for more than 1 million rows) I have been able to generate 8 million combinations with less than 8000 results actually listed in less than a minute!

 

[SidKol]

Today I encountered again an issue with the limitations.
I have modified the code and it is still working great with a limited amount of options.
However when increasing the options slighty I get errors like overflow and out of memory.

I have added two additional limitations to the final results. (So now there are 3 total)

1: Total value of each combination may not be higher than value of cell 1,1 (MY_MAX) (Current Value = 100,7)
2. Price must be at least equal to MY_MAX2 (Current value 240)
3. Maximum amount of transfers may not exceed amount of MY_MAXTRANSFERS (Current Value = 1)

Now I have the following Input:

With the current settings an extremely low value of maximum 1 change per row from the first (original line) is allowed.
Meaning that the final results can never exceed 90 in this case.

Still I get the message Out of Memory at ReDim avOut(1 To aiCum(1), 1 To nCol)

Is there a way to avoid this?

Option Explicit

Const sTitle        As String = "shg Cartesian Product"


Sub CartesianProduct()
    ' shg 2012, 2013
    ' Choose one from col A, one from col B, ...


    Dim rInp                As Range
    Dim avInp               As Variant  ' ragged input list
    Dim nCol                As Long     ' # columns in list
    Dim rOut                As Range    ' output range
    Dim iCol                As Long     ' column index
    Dim iRow                As Long     ' row index
    Dim aiCum()             As Long     ' cum count of arrangements from right to left
    Dim aiCnt()             As Long     ' count of items in each column
    Dim iArr                As Long     ' arrangement number
    Dim avOut               As Variant  ' output buffer
    
    Dim avValues            As Variant
    Dim lTotal              As Long
    Dim lTotal2             As Long     'added by Sid
    Dim lTotalMAXTRANSFERS  As Long     'added by Sid
    Dim lCount              As Long
    Dim lRow                As Long
        


    avValues = Range("R4:AV15").Value
    lCount = 1
    
    Application.ScreenUpdating = False
    
    
    'SET MAXIMUM VALUE Type 1
    Dim MY_MAX As Double                'set to double because it contains a comma
    MY_MAX = Cells(1, 1).Value          'should be 100,7


    'SET MINIMUM VALUE Type 2 / PRICE
    Dim avValues2    As Variant
    avValues2 = Range("AH4:AV15").Value
    Const MY_MAX2 = 240


    'SET MAX CHANGES ALLOWED
    Dim avValuesTRANSFERMAX    As Variant
    avValuesTRANSFERMAX = Range("AX4:BL15").Value
    Const MY_MAXTRANSFERS = 1




   




'rInp i
    Set rInp = Range("rgnInp")
    If VarType(rInp.Value) = vbEmpty Then
        MsgBox Prompt:="No input!", _
               Buttons:=vbOKOnly, _
               Title:=sTitle
        Exit Sub
    End If


    Set rInp = rInp.CurrentRegion
    If rInp.Columns.Count < 2 Or rInp.Rows.Count < 2 Then
        MsgBox Prompt:="Must have more than one row and more than one columns!", _
               Buttons:=vbOKOnly, _
               Title:=sTitle
        Exit Sub
    End If




    With rInp
        .Style = "Input"
        avInp = .Value
        nCol = .Columns.Count
        Set rOut = .Resize(1).Offset(.Rows.Count + 1)
        Range(rOut.Offset(-1, -1), Cells(Rows.Count, Columns.Count)).Clear
    End With


    ReDim aiCum(1 To nCol + 1)
    ReDim aiCnt(1 To nCol)
    aiCum(nCol + 1) = 1




    For iCol = nCol To 1 Step -1
        For iRow = 1 To UBound(avInp, 1)
            If IsEmpty(avInp(iRow, iCol)) Then Exit For
            aiCnt(iCol) = aiCnt(iCol) + 1
        Next iRow


        aiCum(iCol) = aiCnt(iCol) * aiCum(iCol + 1)
    Next iCol
    


    If aiCum(1) > Rows.Count - rOut.Row + 1 Then
        MsgBox Prompt:=Format(aiCum(1), "#,##0") & _
                       " is too many rows!", _
               Buttons:=vbOKOnly, Title:=sTitle
        'Exit Sub  - Removed by Sid to avoid unneccesary stopping
    End If




    ReDim avOut(1 To aiCum(1), 1 To nCol)


For iArr = 1 To aiCum(1)
    lTotal = 0
    lTotal2 = 0     'added by Sid
    lTotalMAXTRANSFERS = 0
    
    
    For iCol = 1 To nCol
        lRow = (Int((iArr - 1) * aiCnt(iCol) / aiCum(iCol))) Mod aiCnt(iCol) + 1
        avOut(lCount, iCol) = avInp(lRow, iCol)
        lTotal = lTotal + avValues(lRow, iCol)
        lTotalMAXTRANSFERS = lTotalMAXTRANSFERS + avValuesTRANSFERMAX(lRow, iCol)
        lTotal2 = lTotal2 + avValues2(lRow, iCol)               'added by Sid
        
        
        If lTotal > MY_MAX Then Exit For
        If lTotal2 > MY_MAX2 Then Exit For                      'added by Sid
        If lTotalMAXTRANSFERS > MY_MAXTRANSFERS Then Exit For   'added by Sid
        
    Next iCol
    If iCol = nCol + 1 Then lCount = lCount + 1
Next iArr


If lCount = 1 Then
    MsgBox "No values found!"
Else
    With rOut.Resize(lCount - 1, nCol)
        .NumberFormat = "@"
        .Value = avOut
        '.Style = "Code"
        .Cells(1, 0).Value = 1
        .Cells(2, 0).Value = 2
        .Cells(1, 0).Resize(2).AutoFill .Columns(0)
    End With
End If
    


    ActiveWindow.FreezePanes = False
    rOut.EntireColumn.AutoFit
    ActiveSheet.UsedRange
    Beep
End Sub

 

[StephenCrump]

With the layout shown, the current code will need to loop through 12^6 * 2^9 = approximately 1.5 billion combinations. To accommodate these, it's trying to set up an array with 1.5 billion rows x 15 columns, i.e. way too big for memory.

My suggested quick patch:

'Extra declaration
Const MAX_TO_SHOW = 100  'maximum number of results to display

'...

'Replace
ReDim avOut(1 To aiCum(1), 1 To nCol)
'with
ReDim avOut(1 To MAX_TO_SHOW, 1 To nCol)

'later in the code
For iArr = 1 To aiCum(1)
    '....
    '....
    If iCol = nCol + 1 Then lCount = lCount + 1
    'Add this new line
    If lCount > MAX_TO_SHOW Then Exit For
Next iArr

You may still get an overflow error on this line:

aiCum(iCol) = aiCnt(iCol) * aiCum(iCol + 1)

because the number of combinations has exceeded the capacity of the Long data type (approximately 2.1 billion).

I haven't tried to run your code to see how long it might take. But with this many combinations, you're pushing the boundaries of what you can achieve using a brute force approach, i.e. going through every possible combination, rather than using a smarter approach to narrow down the possibilities that need to be tested.

 

[SidKol]

Hi Stephen,

Thank you very much again for your time and effort!
Greatly appreciated.

Unfortunately the patch doesn't resolve the issue:
It gives a runtime error on another line:

For iCol = 1 To nCol
        lRow = (Int((iArr - 1) * aiCnt(iCol) / aiCum(iCol))) Mod aiCnt(iCol) + 1

Run-time error '6':
Overflow

I guess you are right and the current set-up is just not the way to go.
After a quick calculation I found that this way it should be able to handle a maximum of at about 2 trillion combinations.

A more efficient approach will be needed using the limitations on price, value and/or max. amount of changes.
Which most likely will require even deeper VBA-knowledge...


One way I can think of is the following based on the max. amount of changes set to 4: (MY_MAXTRANSFERS)

With a max. of 1 change to the original line (top row) there are only : 65 possible variations to the original line. (11

With a max. of 2 changes to the top row there are : 4.160 possible variations

With a max. of 3 changes to top row: 262.080

With a max of 4 changes to top row: 16.248.960

Still a lot, but definetly a great amount less than 2 trillion


Would this be a good direction, or do you feel there is a more efficient way?