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

 

[StephenCrump]

The overflow error is because the product: (iArr - 1) * aiCnt(iCol) will sometimes exceed the capacity of the Long data type, i.e. around 2.1 billion.

There are ways around it, e.g. I sometimes use the Currency data type to accommodate large numbers of combinations.

But there comes a point when you have to give up a brute force approach and think of something smarter to cut down the potential combinations to a manageable number. Although in theory VBA can be set up to test trillions of combinations by brute force, you'd need to be booking time on a much faster computer if you actually wanted to do this.

To give a simple example (I haven't tried to follow what your latest code is doing) let's say we have 10 variables A-J, which can each independently take the values 1-10, i.e. 10^10 = 10 billion possible combinations.

If we want the total of A-J to always equal 87 or greater, say, then:

- After generating A, we need to loop only through MAX(1,7-A) to 10 for B
- After generating A and B, we need to loop only through MAX(1,17-A-B) to 10 for C, etc etc.

i.e. we can cut down the number of combinations by putting in some thought up front.

 

[SidKol]

Hi Stephen,

As much as I understood what is necessary to speed up the code, I just could not understand how to implement it in the existing code.
Most of the code is simply out of my league for now.
I've been trying for weeks now to dive into it, but there's too much I just can't figure out.

Therefore I have challenged myself with creating a similar code.
After some days of googling around and watching YouTube video's I actually managed to do this.
Really proud of it! (Even though the code will look absolutely amateur to anybody with slightly more VBA-experience)
But it does the job! and I did'nt copy-paste a single line of code from any other source.
Great feeling!


What it does now is that it writes down every possible combination, but only loops through the combinations as long as the total price is under 145 and there are no more than 2 changes to the original first line.

So it does work, but I am sure that the way I put the conditions still does not fully optimize the speed.

What I would like to ask is if you can have a look and if possible give me some suggestions about how to modify my code in a more "speedefficient" way.

Sub Sid_CombiWithRestrictions()

    
    'start from row 20 with results
    x = 20

'added a counter to view how the code is progressing, can be deleted in final version.
    counter = 0
        
            'Loop through all values in 15 columns
            'Values per column indicated in first row of columns with formula =14-COUNTIF(A4:A17;"")
            For a = 4 To 4 + Cells(1, 1).Value - 1
            For b = 4 To 4 + Cells(1, 2).Value - 1
            For c = 4 To 4 + Cells(1, 3).Value - 1
            For d = 4 To 4 + Cells(1, 4).Value - 1
            For e = 4 To 4 + Cells(1, 5).Value - 1
            For f = 4 To 4 + Cells(1, 6).Value - 1
            For g = 4 To 4 + Cells(1, 7).Value - 1
            For h = 4 To 4 + Cells(1, 8).Value - 1
            For i = 4 To 4 + Cells(1, 9).Value - 1
            For j = 4 To 4 + Cells(1, 10).Value - 1
            For k = 4 To 4 + Cells(1, 11).Value - 1
            For l = 4 To 4 + Cells(1, 12).Value - 1
            For m = 4 To 4 + Cells(1, 13).Value - 1
            For n = 4 To 4 + Cells(1, 14).Value - 1
            For o = 4 To 4 + Cells(1, 15).Value - 1
            
             'run the counter to indicate progress of running code
            counter = counter + 1
            Cells(1, 21) = counter / Cells(1, 22) * 100
            
            
                'Only give results if summed value of cells 1-14 exceeds 145
                If Cells(a, 17).Value _
                        + Cells(b, 18).Value _
                        + Cells(c, 19).Value _
                        + Cells(d, 20).Value _
                        + Cells(e, 21).Value _
                        + Cells(f, 22).Value _
                        + Cells(g, 23).Value _
                        + Cells(h, 24).Value _
                        + Cells(i, 25).Value _
                        + Cells(j, 26).Value _
                        + Cells(k, 27).Value _
                        + Cells(l, 28).Value _
                        + Cells(m, 29).Value _
                        + Cells(n, 30).Value _
                        > 145 Then
                        
                    
                    
                    
                    'Only give results if summed value of changes is 2 or less
                    
                    max_changes = 2
                    
                    Changecounter = Cells(a, 33).Value + Cells(b, 34).Value
                    
                    
                    If Changecounter < max_changes + 1 Then
                    Changecounter = Changecounter + Cells(c, 35).Value
                        
                        If Changecounter < max_changes + 1 Then
                        Changecounter = Changecounter + Cells(d, 36).Value
                        
                            If Changecounter < max_changes + 1 Then
                            Changecounter = Changecounter + Cells(e, 37).Value
                            
                                If Changecounter < max_changes + 1 Then
                                Changecounter = Changecounter + Cells(f, 38).Value
                                
                                    If Changecounter < max_changes + 1 Then
                                    Changecounter = Changecounter + Cells(g, 39).Value
                                    
                                        If Changecounter < max_changes + 1 Then
                                        Changecounter = Changecounter + Cells(h, 40).Value
                                        
                                            If Changecounter < max_changes + 1 Then
                                            Changecounter = Changecounter + Cells(i, 41).Value
                                            
                                                If Changecounter < max_changes + 1 Then
                                                Changecounter = Changecounter + Cells(j, 42).Value
                                                
                                                    If Changecounter < max_changes + 1 Then
                                                    Changecounter = Changecounter + Cells(k, 43).Value
                                                
                                                        If Changecounter < max_changes + 1 Then
                                                        Changecounter = Changecounter + Cells(l, 44).Value
                                                        
                                                            If Changecounter < max_changes + 1 Then
                                                            Changecounter = Changecounter + Cells(m, 45).Value
                                                            
                                                                If Changecounter < max_changes + 1 Then
                                                                Changecounter = Changecounter + Cells(n, 46).Value
                                                                
                                                                    If Changecounter < max_changes + 1 Then
                                                                    Changecounter = Changecounter + Cells(o, 47).Value
                                                                    
                                                                        If Changecounter < max_changes + 1 Then
                                                                    
                     
                        
                        
                 
                        'Create a row with results
                        Cells(x, 1) = Cells(a, 1)
                        Cells(x, 2) = Cells(b, 2)
                        Cells(x, 3) = Cells(c, 3)
                        Cells(x, 4) = Cells(d, 4)
                        Cells(x, 5) = Cells(e, 5)
                        Cells(x, 6) = Cells(f, 6)
                        Cells(x, 7) = Cells(g, 7)
                        Cells(x, 8) = Cells(h, 8)
                        Cells(x, 9) = Cells(i, 9)
                        Cells(x, 10) = Cells(j, 10)
                        Cells(x, 11) = Cells(k, 11)
                        Cells(x, 12) = Cells(l, 12)
                        Cells(x, 13) = Cells(m, 13)
                        Cells(x, 14) = Cells(n, 14)
                        Cells(x, 15) = Cells(o, 15)
                
                        'Set the next row for results
                        x = x + 1
                
                    
                    
                                                                        End If
                                                                    End If
                                                                End If
                                                            End If
                                                        End If
                                                    End If
                                                End If
                                            End If
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    End If
                    
                    
                End If
                          
            'continue looping
            Next o
            Next n
            Next m
            Next l
            Next k
            Next j
            Next i
            Next h
            Next g
            Next f
            Next e
            Next d
            Next c
            Next b
            Next a
        
End Sub

 

[StephenCrump]

After some days of googling around and watching YouTube video's I actually managed to do this.
Really proud of it! (Even though the code will look absolutely amateur to anybody with slightly more VBA-experience)
But it does the job! and I did'nt copy-paste a single line of code from any other source.
Great feeling!

Well done!

What I would like to ask is if you can have a look and if possible give me some suggestions about how to modify my code in a more "speedefficient" way.

The main thing really slowing down your code is all the VBA/Excel interfacing - VBA asking Excel what the value of a cell is, or VBA telling Excel to write a value to a cell. You may want to start playing with VBA arrays (which was how the original code was written). Here's a simple example, just to illustrate the potential time saving:

Sub Test()

    Dim vIn As Variant, vOut As Variant
    Dim rngIn As Range, rngOut As Range
    Dim i As Long, j As Long
    Dim RunTime As Double
    
    Application.ScreenUpdating = False
    Set rngIn = Range("A1:H100")
    
    With rngIn
        Set rngOut = .Offset(, .Columns.Count + 1)
        .Formula = "=8*(ROW()-1)+COLUMN()"
        
        'Method 1. Cell by cell read and write
        RunTime = Timer
        For i = 1 To rngIn.Rows.Count
            For j = 1 To rngIn.Columns.Count
                rngOut.Cells(i, j).Value = .Cells(i, j).Value ^ 2
            Next j
        Next i
        RunTime = Timer - RunTime
        MsgBox "Time1: " & Format(RunTime, "0.00") & " sec"
    
        'Method 2. VBA array
        RunTime = Timer
        vIn = rngIn.Value2
        ReDim vOut(1 To UBound(vIn), 1 To UBound(vIn, 2))
        For i = 1 To UBound(vIn)
            For j = 1 To UBound(vIn, 2)
                vOut(i, j) = vIn(i, j) ^ 2
            Next j
        Next i
        rngOut.Value = vOut
        RunTime = Timer - RunTime
        MsgBox "Time2: " & Format(RunTime, "0.00") & " sec"
    End With
        
    Application.ScreenUpdating = True

End Sub