Loop through VBA based on ascending variable values

[Ian_Starkey]

Futoshiki is a Japanese puzzle solved by placing unique numbers in rows and columns of a square grid and solved by using operands “<” and “>” to determine the correct value. I have written some vba to solve a 7x7 grid that a) initially works out the possible values for a given row and then b) places each row value in a row followed by the next row. Then if the logic still works, the code adds another row until finally I have 7 correct rows meeting the structure of the initial operands.

The possible valid combinations for each row are held in a worksheet called “Possibles”. The code loops to CheckMathsCol which holds the operands and returns an errchk =1 if a combination is incorrect. Then it backtracks and starts again on the last row that failed with the next possible value of that row.

My code works but because I start at row 1 and if row 1 or maybe row 2 or 3 has many possible values this can result in checking many combinations which can take a few hours to solve. However, if I am able to start with the row that has the least possible values then it takes minutes to solve. At the moment I rewrite the code to perform the solve in the most efficient way.

My first example is my default code and this took 2 hrs 30 mins to solve mainly because of the high number of possible values in early rows e.g. row 2 (variable nr2) has 750 possible values; row 3, nr3 1434 values and row 4, nr4, 930 values.
If I rearrange my code as per the second example, which took about a minute to solve, because it starts with row 6 (variable nr6) which has 45 possible values; then row 7, nr7, with 64 values and row 1, nr1, 66 values etc.

But for the code to be efficient as per the second example I have to rewrite it for every puzzle having first worked out which row has the least possible valid values.

Can you help me in automating which row, based on the least possible values, starts first. I hope this makes sense and appreciate any feedback for any bad vba practices (as I have written this as a hobby). Many thanks.

Default Example – code written based on row 1 being solved before row 2 etc. all the way to row 7

Sub DefinePossArraySingleWithCalculate()

Dim dTime As Double
dTime = Now()
Worksheets("Answer").Range("N5").Value = Format(Now(), "hh:mm:ss")

Dim nr1, nr2, nr3, nr4, nr5, nr6, nr7 As Long
Dim rowchk1, rowchk2, rowchk3, rowchk4, rowchk5, rowchk6, rowchk7 As Long
Dim i As Long, j As Long

Application.ScreenUpdating = False
Worksheets("Possibles").Activate

nr1 = Range("A2", Range("A2").End(xlDown)).Cells.Count 'worked out to be 66 values
nr2 = Range("I2", Range("I2").End(xlDown)).Cells.Count 'worked out to be 750 values
nr3 = Range("Q2", Range("Q2").End(xlDown)).Cells.Count 'worked out to be 1434 values
nr4 = Range("Y2", Range("Y2").End(xlDown)).Cells.Count 'worked out to be 930 values
nr5 = Range("AG2", Range("AG2").End(xlDown)).Cells.Count 'worked out to be 696 values
nr6 = Range("AO2", Range("AO2").End(xlDown)).Cells.Count 'worked out to be 45 values
nr7 = Range("AW2", Range("AW2").End(xlDown)).Cells.Count 'worked out to be 64 values

'Setup
errchk = 0

For i = 1 To 7
 For j = 1 To 7
  SetupNos(i, j) = Worksheets("Setup").Range("a1").Offset(i - 1, j - 1).Value 'this is the initial grid given from the puzzle
 PossPerms(i, j) = Worksheets("Setup").Range("a1").Offset(i - 1, j - 1).Value
 Next j
Next i

'Answer
Worksheets("Answer").Activate
Worksheets("Answer").Range("A1:K7").ClearContents 'clear any old data
Worksheets("Answer").Range("A1:G7").Value = SetupNos() 'put in initial values

For rowchk1 = 1 To nr1   'starts with the row 1 = 66 combinations

 For j = 1 To 7
  PossPerms(1, j) = Sheet1.Range("A" & rowchk1 + 1).Offset(0, j - 1).Value     'load the array with the first row of data
Next j

For rowchk2 = 1 To nr2 'add row 2 = 750 combinations
 For j = 1 To 7
  PossPerms(2, j) = Sheet1.Range("I" & rowchk2 + 1).Offset(0, j - 1).Value      'load the array with the second row of data
Next j

CheckMathsCol      'check whether combination of the data rows are valid and...
If errchk < 1 Then   'if no errors then add next row

For rowchk3 = 1 To nr3 'add row 3 = 1434 combinations
 For j = 1 To 7
  PossPerms(3, j) = Sheet1.Range("Q" & rowchk3 + 1).Offset(0, j - 1).Value 'load the array with the third row of data
 Next j

CheckMathsCol 'check whether combination of the data rows are valid and...
If errchk < 1 Then 'if no errors then add next row

For rowchk4 = 1 To nr4 'add row 4 = 930 combinations
 For j = 1 To 7
  PossPerms(4, j) = Sheet1.Range("Y" & rowchk4 + 1).Offset(0, j - 1).Value 'load the array with the fourth row of data  
 Next j

CheckMathsCol      'check whether combination of the data rows are valid and...
If errchk < 1 Then   'if no errors then add next row

For rowchk5 = 1 To nr5    'add row 5 = 696 combinations
 For j = 1 To 7
  PossPerms(5, j) = Sheet1.Range("AG" & rowchk5 + 1).Offset(0, j - 1).Value 'load the array with the fifth row of data
 Next j

CheckMathsCol 'check whether combination of the data rows are valid and...
If errchk < 1 Then 'if no errors then add next row

For rowchk6 = 1 To nr6 'add row 6 = 45 combinations
 For j = 1 To 7
  PossPerms(6, j) = Sheet1.Range("AO" & rowchk6 + 1).Offset(0, j - 1).Value 'load the array with the sixth row of data
Next j

CheckMathsCol       'check whether combination of the data rows are valid and...
If errchk < 1 Then   'if no errors then add next row

For rowchk7 = 1 To nr7 'add row 7 = 64 combinations
 For j = 1 To 7
  PossPerms(7, j) = Sheet1.Range("AW" & rowchk7 + 1).Offset(0, j - 1).Value 'load the array with the last row of data
 Next j

CheckMathsCol 'check whether combination of the data rows are valid and...
If errchk < 1 Then 'at this point the puzzle is solved

'Print out Time to run Macro and exit
Worksheets("Answer").Activate
Worksheets("Answer").Range("A1", "G7").Value = PossPerms()
Worksheets("Answer").Range("N6").Value = Format(Now(), "hh:mm:ss")
Worksheets("Answer").Range("N7").Value = Format((Now() - dTime), "hh:mm:ss")

Erase PossPerms()
Erase SetupNos()

Exit Sub  'finish if correct

End If
Next rowchk7

For j = 1 To 7
PossPerms(7, j) = Worksheets("Setup").Range("a1").Offset(6, j - 1).Value 'resets the variable if the answer is incorrect
Next j

rowchk7 = 1 'starts again

End If
Next rowchk6

For j = 1 To 7
PossPerms(6, j) = Worksheets("Setup").Range("a1").Offset(5, j - 1).Value 'resets the variable if the answer is incorrect
Next j

rowchk6 = 1 'starts again

End If
Next rowchk5

For j = 1 To 7
PossPerms(5, j) = Worksheets("Setup").Range("a1").Offset(4, j - 1).Value 'resets the variable if the answer is incorrect
Next j

rowchk5 = 1 'starts again

End If
Next rowchk4

For j = 1 To 7
 PossPerms(4, j) = Worksheets("Setup").Range("a1").Offset(3, j - 1).Value 'resets the variable if the answer is incorrect
Next j

rowchk4 = 1 'starts again

End If
Next rowchk3

For j = 1 To 7
 PossPerms(3, j) = Worksheets("Setup").Range("a1").Offset(2, j - 1).Value 'resets the variable if the answer is incorrect
Next j

rowchk3 = 1 'starts again

End If
Next rowchk2

For j = 1 To 7
 PossPerms(2, j) = Worksheets("Setup").Range("a1").Offset(1, j - 1).Value 'resets the variable if the answer is incorrect
Next j

rowchk2 = 1 'starts again

Worksheets("Answer").Range("A1:G7").Value = SetupNos()
Next rowchk1 'takes the next row

Worksheets("Answer").Activate
Application.ScreenUpdating = True

End Sub

Second Example – code rewritten based on ascending values of variable nr1 to nr7, ie. nr6 first followed by nr5 etc.

Sub DefinePossArraySingleWithCalculate()

Dim dTime As Double
dTime = Now()
Worksheets("Answer").Range("N5").Value = Format(Now(), "hh:mm:ss")

Dim nr1, nr2, nr3, nr4, nr5, nr6, nr7 As Long
Dim rowchk1, rowchk2, rowchk3, rowchk4, rowchk5, rowchk6, rowchk7 As Long
Dim i As Long, j As Long

Application.ScreenUpdating = False
Worksheets("Possibles").Activate

nr1 = Range("A2", Range("A2").End(xlDown)).Cells.Count 'worked out to be 66 values
nr2 = Range("I2", Range("I2").End(xlDown)).Cells.Count 'worked out to be 750 values
nr3 = Range("Q2", Range("Q2").End(xlDown)).Cells.Count 'worked out to be 1434 values
nr4 = Range("Y2", Range("Y2").End(xlDown)).Cells.Count 'worked out to be 930 values
nr5 = Range("AG2", Range("AG2").End(xlDown)).Cells.Count 'worked out to be 696 values
nr6 = Range("AO2", Range("AO2").End(xlDown)).Cells.Count 'worked out to be 45 values
nr7 = Range("AW2", Range("AW2").End(xlDown)).Cells.Count 'worked out to be 64 values

'Setup
errchk = 0

For i = 1 To 7
 For j = 1 To 7
  SetupNos(i, j) = Worksheets("Setup").Range("a1").Offset(i - 1, j - 1).Value 'this is the initial grid given from the puzzle
  PossPerms(i, j) = Worksheets("Setup").Range("a1").Offset(i - 1, j - 1).Value

Next j
Next i

'Answer
Worksheets("Answer").Activate
Worksheets("Answer").Range("A1:K7").ClearContents 'clear any old data
Worksheets("Answer").Range("A1:G7").Value = SetupNos() 'put in initial values

For rowchk6 = 1 To nr6 'start with the smallest value = 45 combinations
For j = 1 To 7
 PossPerms(6, j) = Sheet1.Range("AO" & rowchk6 + 1).Offset(0, j - 1).Value 'load the array with the first row of data
Next j

For rowchk7 = 1 To nr7 'next smallest value = 64 combinations
 For j = 1 To 7
  PossPerms(7, j) = Sheet1.Range("AW" & rowchk7 + 1).Offset(0, j - 1).Value 'load the array with the second row of data
 Next j

CheckMathsCol 'check whether combination of the data rows are valid and...
If errchk < 1 Then 'if no errors then add next row

For rowchk1 = 1 To nr1 'next smallest value = 66 combinations
 For j = 1 To 7
  PossPerms(1, j) = Sheet1.Range("A" & rowchk1 + 1).Offset(0, j - 1).Value 'load the array with the third row of data
 Next j

CheckMathsCol 'check whether combination of the data rows are valid and..
If errchk < 1 Then 'if no errors then add next row

For rowchk5 = 1 To nr5 'next smallest value = 696 combinations
 For j = 1 To 7
  PossPerms(5, j) = Sheet1.Range("AG" & rowchk5 + 1).Offset(0, j - 1).Value 'load the array with the fourth row of data
 Next j

CheckMathsCol 'check whether combination of the data rows are valid and..
If errchk < 1 Then 'if no errors then add next row

For rowchk2 = 1 To nr2 'next smallest value = 750 combinations
 For j = 1 To 7
 PossPerms(2, j) = Sheet1.Range("I" & rowchk2 + 1).Offset(0, j - 1).Value 'load the array with the fifth row of data
Next j

CheckMathsCol 'check whether combination of the data rows are valid and..
If errchk < 1 Then 'if no errors then add next row

For rowchk4 = 1 To nr4 'next smallest value = 930 combinations
 For j = 1 To 7
  PossPerms(4, j) = Sheet1.Range("Y" & rowchk4 + 1).Offset(0, j - 1).Value 'load the array with the sixth row of data
Next j

CheckMathsCol 'check whether combination of the data rows are valid and..
If errchk < 1 Then 'if no errors then add next row

For rowchk3 = 1 To nr3 'largest last = 1434 combinations
 For j = 1 To 7
  PossPerms(3, j) = Sheet1.Range("Q" & rowchk3 + 1).Offset(0, j - 1).Value 'load the array with the seventh row of data
 Next j

CheckMathsCol 'check whether combination of the data rows are valid and..
If errchk < 1 Then 'at this point the puzzle is solved

'Print out Time to run Macro and exit
Worksheets("Answer").Activate
Worksheets("Answer").Range("A1", "G7").Value = PossPerms()
Worksheets("Answer").Range("N6").Value = Format(Now(), "hh:mm:ss")
Worksheets("Answer").Range("N7").Value = Format((Now() - dTime), "hh:mm:ss")

Erase PossPerms()
Erase SetupNos()

Exit Sub

End If
Next rowchk3
For j = 1 To 7
 PossPerms(3, j) = Worksheets("Setup").Range("a1").Offset(2, j - 1).Value 'resets the variable if the answer is incorrect
Next j

rowchk3 = 1 'starts again
End If

Next rowchk4
 For j = 1 To 7
  PossPerms(4, j) = Worksheets("Setup").Range("a1").Offset(3, j - 1).Value 'resets the variable if the answer is incorrect
 Next j

rowchk4 = 1 'starts again
End If

Next rowchk2
 For j = 1 To 7
 PossPerms(2, j) = Worksheets("Setup").Range("a1").Offset(3, j - 1).Value 'resets the variable if the answer is incorrect
Next j

rowchk2 = 1 'starts again
End If

Next rowchk5
For j = 1 To 7
 PossPerms(5, j) = Worksheets("Setup").Range("a1").Offset(4, j - 1).Value 'resets the variable if the answer is incorrect
Next j

rowchk5 = 1 'starts again
End If

Next rowchk1
 For j = 1 To 7
  PossPerms(1, j) = Worksheets("Setup").Range("a1").Offset(0, j - 1).Value 'resets the variable if the answer is incorrect
Next j

rowchk1 = 1 'starts again
End If

Next rowchk7
 For j = 1 To 7
  PossPerms(7, j) = Worksheets("Setup").Range("a1").Offset(6, j - 1).Value 'resets the variable if the answer is incorrect
 Next j

rowchk7 = 1 'starts again

Worksheets("Answer").Range("A1:G7").Value = SetupNos()
Next rowchk6 'takes the next row

Worksheets("Answer").Activate
Application.ScreenUpdating = True

 End Sub

 

[StephenCrump]

Welcome to the Forum!

Interesting puzzles. I'd never heard of them.

I suggest the first step is to create a sorted table. My code below assumes it exists in Excel, but you could also create a VBA array ....

	A	B
1	Summary	(sorted)
2	6	45
3	7	64
4	1	66
5	5	696
6	2	750
7	4	930
8	3	1,434
Sheet1

Summary: =Sheet1!$A$2:$B$8

Then you could do something like this:

Sub GetStarted()

    Dim Summary As Variant, AllPerms() As Variant, PermToCheck() As Long
    Dim N As Long, j As Long, rowchk1 As Long, rowchk2 As Long 'etc
    Const Nos = 7
    ReDim PermToCheck(1 To Nos, 1 To Nos)
    
    With Range("Summary")
        Summary = .Value2
        N = Application.Max(.Columns(2))
    End With
    AllPerms = Range("A2").Resize(N, Nos * (Nos + 1)).Value2
    
    For rowchk1 = 1 To Summary(1, 2)
        For j = 1 To Nos
            PermToCheck(1, j) = AllPerms(rowchk1, (Summary(1, 1) - 1) * (Nos + 1) + j)
        Next j
        For rowchk2 = 1 To Summary(2, 2)
            For j = 1 To Nos
                PermToCheck(2, j) = AllPerms(rowchk2, (Summary(2, 1) - 1) * (Nos + 1) + j)
            Next j
            For rowchk3 = 1 To Summary(3, 2)
            'etc
                        
            Next rowchk3
        Next rowchk2
    Next rowchk1

End Sub

Once you've got it working, the next level coding challenge would be to write this recursively. Then you could handle any Nos x Nos puzzle, rather than hardcoding seven nested loops.

 

[Ian_Starkey]

Stephen
Many thanks for that code.
I hadn't thought about simplifying the initial output, but it makes sense. It is easy enough to derive the sorted table on another sheet and I'll add your code and run it against a few puzzles I have.

Recursive - now there's a challenge!
Cheers
Ian