VBA script optimisation to solve a puzzle with an underdetermined system
I received a puzzle when I just entered college and with my then lacking mathematical knowledge I wasn't able to solve it. Over the years I returned to the puzzle and was able to determine at least one solution and with my current still lacking mathematical knowledge I'm able to determine that the puzzle contains an underdetermined system of 10 formulas and 12 unknowns. At least one solution exists. My latest attempt in solving it was done with rudimentary programming skills in vba by bruteforcing all solutions. My scripts was able to find the solution I already had but was way to slow to determine any other solutions(my patience ran out before the script was done running).
The puzzle: (https://i.sstatic.net/xnXvZ.jpg).
I tried solving the multiple equations by looping through the variables and continuing with a next loop if a solution for the equation is found. While this works fine in thought, in practice it required a loop for each variable, in this case 12 which makes for a very slow process. I've tried making it quicker by moving some if statements earlier in the loops but this didn't really made a difference. I know that adding multiple loops inside each other doesn't make for good code but I can't think of something better.
With my lacking programming and mathematical skills I can't think of a quicker solution to solve the puzzle than looping through each variable. I was hoping for some help with this.
My code:
For a = 1 To 100
For b = 1 To 100
If 10 - a + 38 + b * 42 = 114 Then
For c = 1 To 100
For d = 1 To 100
For e = 1 To 100
If c - 2 + d + 6 * e = 37 Then
For f = 1 To 100
For g = 1 To 100
If 50 - f * 3 - g / 5 = -4 Then
For h = 1 To 100
For j = 1 To 100
For k = 1 To 100
If h + 15 - j * 3 - k = 2 Then
For l = 1 To 1000
For m = 1 To 100
If 20 * l + 12 / m + 8 = 171 Then
If 10 + c * 50 + h + 20 = 186 Then
If a * 2 - f + 15 - l = 111 Then
If 38 - d * 3 - j + 12 = -28 Then
If b + 6 + g - 3 * m = 27 Then
If 42 * e - 5 - k - 8 = 70 Then
r = r + 1
With Worksheets("Sheet1")
.Cells(r, 5).Value = a
.Cells(r, 6).Value = b
.Cells(r, 7).Value = c
.Cells(r, 8).Value = d
.Cells(r, 9).Value = e
.Cells(r, 10).Value = f
.Cells(r, 11).Value = g
.Cells(r, 12).Value = h
.Cells(r, 13).Value = j
.Cells(r, 14).Value = k
.Cells(r, 15).Value = l
.Cells(r, 16).Value = m
.Cells(r, 4).Value = Format(Timer - t, "hh:mm:ss")
End With
End If
End If
End If
End If
End If
End If
Next m
Next l
End If
Next k
Next j
Next h
End If
Next g
Next f
End If
Next e
Next d
Next c
End If
Next b
Next a
In this example code I've only run it within the boundaries of 1 to 100 which gives me an solution after about 15 minutes. A range in which all solutions would be produces would probably take too long. So I'm kindoff stuck without help.
Is it considered cheating to simplify some of the equations? You can define 7 of the variables in terms of other variables, so instead of looping for 12 variables, you only have to loop for 5.
I tried your original way and gave up after 3 minutes of running. I tried with the simplified variables and it only took 4 seconds. I also tried 1 to 200 and -100 to 100, and still only 1 solution. Those runs took less than a minute so you might find more solutions if you're willing to wait.
I also changed your 1 to 100 to variables to make it easier to expand the range and test for negative solutions.
Sub solve_problem()
intMIN = 1
intMAX = 150
Start = Now
For a = intMIN To intMAX
' For B = intMIN To intMAX
b = (a + 66) / 42
If 10 - a + 38 + b * 42 = 114 Then
For c = intMIN To intMAX
For d = intMIN To intMAX
For e = intMIN To intMAX
If c - 2 + d + 6 * e = 37 Then
For f = intMIN To intMAX
' For g = intMIN To intMAX
g = 270 - 15 * f
If 50 - f * 3 - g / 5 = -4 Then
' For h = intMIN To intMAX
h = 156 - (50 * c)
' For j = intMIN To intMAX
j = 78 - 3 * d
' For k = intMIN To intMAX
k = 42 * e - 83
If h + 15 - j * 3 - k = 2 Then
' For L = intMIN To intMAX
l = 84 * b - f - 228
' For m = intMIN To intMAX
m = 12 / (163 - 20 * l)
If 20 * l + 12 / m + 8 = 171 Then
If 10 + c * 50 + h + 20 = 186 Then
If a * 2 - f + 15 - l = 111 Then
If 38 - d * 3 - j + 12 = -28 Then
If b + 6 + g - 3 * m = 27 Then
If 42 * e - 5 - k - 8 = 70 Then
r = r + 1
With Worksheets("Sheet1")
.Cells(r, 5).Value = a
.Cells(r, 6).Value = b
.Cells(r, 7).Value = c
.Cells(r, 8).Value = d
.Cells(r, 9).Value = e
.Cells(r, 10).Value = f
.Cells(r, 11).Value = g
.Cells(r, 12).Value = h
.Cells(r, 13).Value = j
.Cells(r, 14).Value = k
.Cells(r, 15).Value = l
.Cells(r, 16).Value = m
.Cells(r, 4).Value = Format(Now - Start, "hh:mm:ss")
End With
End If
End If
End If
End If
End If
End If
' Next m
' Next L
End If
' Next k
' Next j
' Next h
End If
' Next g
Next f
End If
Next e
Next d
Next c
End If
' Next B
Next a
r = r + 1
Worksheets("Sheet1").Cells(r, 4).Value = Format(Now - Start, "hh:mm:ss")
End Sub
Here is the work for isolating the variables
- How to make Colors Mixer in vba
- How to get HEX color value from cell color?
- SSIS: Insert multiple Excel files with same format but different file name to multiple database table destinations based on the Excel filename
- How to randomize Excel rows
- VLOOKUP Returns 0 even though there is a value in the line below the first result
- transpose a table with multiple values in excel
- Trying to late bind outlook to but getting type mismatch error after create object line
- Power Query Transform a Column based on Another Column
- Apply FILTER formula to array (and use filter criteria on specific column in the array)
- Bitly API call using VBA Excel Macro
- excel vba projects not closing
- In a standard MS Access SQL query output that does not have any aliases, how do I replace the full names by their "first-letters" aliases?
- Sigma or Summation function in Excel
- Problem getting the value from a cell using M in excel
- INDEX MATCH to also pull through notes
- Move formatted data in selection from Excel into Word tables
- Excel VBA function to remove letters at end of string
- Can't get all excel processes to stop when closing through Powershell
- Excel function to construct an array from values without VBA
- Alternative method to delete file with out having to add MS Scripting Runtime Reference
- Add new button to worksheet with Excel Add-in
- Apply outline border only to range of cells with openpyxl
- How to Separate Data with Inconsistent Patterns into a Structured Format in Excel
- Excel - Aggregate dynamically values in a Table using array formulas (MAP, BYROW, CHOOSECOLS, TEXTJOIN, LAMBDA, FILTER, HSTACK) in a single Cell
- How to reference the current User\Desktop location in VBA
- Powerpoint chart to excel relative link
- EXCEL: How do I return multiple columns using XLOOKUP, when the lookup_value is a range?
- VBA: How to Loop IF Statement through a Cell and Chart Series
- Incorporating Checkbox to lines of code rather than Cell value
- How do I remove a character from a column of data in Excel