Only give 100 solutions

[Legacy 287389]

Hi good people!,
This is my code:

Sub AllSolutions()
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim l As Integer
    Dim m As Integer
            
    Dim i1 As Integer
    Dim j1 As Integer
    Dim k1 As Integer
    Dim l1 As Integer
    Dim m1 As Integer
        
    Dim iH As Integer
    Dim iL As Integer
        
    Dim lRow As Long
    Dim Sh1 As Worksheet
    Dim Sh2 As Worksheet
    
    Set Sh1 = Worksheets("Sheet1")
    Set Sh2 = Worksheets("Solutions")
    On Error Resume Next
    Application.DisplayAlerts = False
    On Error GoTo 0
    
    iH = Sh1.Range("A3").Value
    iL = Sh1.Range("A3").Value / Sh1.Range("B3").Value
    
   [I] i1 = Sh1.Range("D2").Value
    j1 = Sh1.Range("E2").Value
    k1 = Sh1.Range("F2").Value
    l1 = Sh1.Range("G2").Value
    m1 = Sh1.Range("H2").Value[/I]       
    lRow = 1
    
    For i = i1 To iH Step i1
     For j = j1 To iH - i Step j1
      For k = k1 To iH - i - j Step k1
       For l = l1 To iH - i - j - k Step l1
        m = iH - i - j - k - l
         If m Mod m1 = 0 Then 'Changed
         If i / i1 + j / j1 + k / k1 + l / l1 + m / m1 = iL Then 'Changed
                        lRow = lRow + 1
                        With Sh2
                            .Cells(lRow, "A") = i
                            .Cells(lRow, "B") = j
                            .Cells(lRow, "C") = k
                            .Cells(lRow, "D") = l
                            .Cells(lRow, "E") = m
                            End With
                        If lRow = 100001 Then
                        MsgBox "Limit of 100 000 solutions calculated"
                            Worksheets("Solutions").Select
                            Exit Sub
                        End If
                       End If
                      End If
                     Next l
                    Next k
                  Next j
                 Next i
Application.ScreenUpdating = False
Worksheets("Solutions").Select
    Range("F2").Select
    Application.Goto Reference:="R2C6:R100001C6"
    Selection.FillDown
    Range("G2").Select
    Application.Goto Reference:="R2C7:R100001C7"
    Selection.FillDown
    Range("H2").Select
    Application.Goto Reference:="R2C8:R100001C8"
    Selection.FillDown
    Range("I2").Select
    Application.Goto Reference:="R2C9:R100001C9"
    Selection.FillDown
    Range("J2").Select
    Application.Goto Reference:="R2C10:R100001C10"
    Selection.FillDown
    Range("A1").Select
 Worksheets("Sheet1").Select
 MsgBox "All Possible Relationships Had Been Calculated"
End Sub

If you focus on the Italic piece of the code, you will notice that I have values from D2 to H2. Just to clarify quickly, what this code does is it gives all possible combinations which, when summed, gives the total value iH. These values have a relationship with the values in D2 to H2. These values are also plotted on the "Solution sheet" columns A to E. Okay, the problem is that the answers start with the value i1. i1 is repeated until all combinations have been calculated. As soon as all possible relationships (combinations) had been calculated, column A steps the original value by i1, and again calculates the possible combinations. The change I would like to have, is to only calculate 100 combinations for each i1 value. Currently I am getting between 40 000 and 50 000 combs for just one i1 value.
I hope this makes sense. if anyone can help, please..I will be forever very very grateful. Thanx people!

 

[WaterGypsy]

At a guess .... you have initially set Sh2=Worksheet("Solutions") ... so when you have filled up your first destination sheet (at "If lRow= 100001 then" you can simply(?) make Sh2=Worksheet("Solutions Page 2") (or whatever it is called) and reset the counter lrow = 1 instead of outputting the Msgbox and exiting.

If lRow = 100001 Then
Sh2=Worksheet("Solutions Page 2")
iRow = 1
end if

Now the troubel with that is that it will fail when you hit 100000 for the 2nd time but I won't take your fun away in trying to work out how to fix that for now

 

[Legacy 287389]

Yep, everyday fun and games with VBA...I will play with it thanx again. I wish you a lovely day..