About the Author

' Generates Sudoku Comparable Squares of order 9, Aale de Winkel

' Tested with Office 2007 under Windows 7

Sub SudSqrs9()

Dim a(4), b(4), s(2), z(2), d(2), A1(81), b9(9)

y = MsgBox("Locked", vbCritical, "Routine SudSqrs9")
End

    Sheets("Klad1").Select
    t1 = Timer

    k1 = 1: k2 = 1: n9 = 0: m2 = 9

'   Define a(), b(), c()

For j1 = 2 To 82    '16
Cells(k1, 1).Value = j1

For i1 = 1 To 4
    a(i1) = Sheets("Constr9").Cells(j1, i1 + 14).Value
Next i1

For j2 = 2 To 82    '60
Cells(k1 + 1, 1).Value = j2

For i1 = 1 To 4
    b(i1) = Sheets("Constr9").Cells(j2, i1 + 14).Value
Next i1

'   Create A1()

    i3 = 0
    For j11 = 5 To 13 'Rows
    
        z(1) = Sheets("Constr9").Cells(j11, 1).Value
        z(2) = Sheets("Constr9").Cells(j11, 2).Value
          
        For j12 = 4 To 12 'Columns
        
        s(1) = Sheets("Constr9").Cells(2, j12).Value
        s(2) = Sheets("Constr9").Cells(3, j12).Value

        
        d(2) = (a(1) * s(1) + a(2) * s(2) + a(3) * z(1) + a(4) * z(2)) Mod 3
        d(1) = (b(1) * s(1) + b(2) * s(2) + b(3) * z(1) + b(4) * z(2)) Mod 3
        
        i3 = i3 + 1
        A1(i3) = 3 * d(2) + d(1)
        
        Next j12
    
    Next j11

'   Exclude solutions with identical numbers in:
'   rows (9), columns (9), main diagonals (2)

    GoSub 1800: If fl1 = 0 Then GoTo 30

    n9 = n9 + 1: GoSub 650

30
20 Next j2
10 Next j1

    t2 = Timer
    t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
    y = MsgBox(t10, 0, "Routine SudSqrs9")

End

'   Print Results (Squares)

650 n2 = n2 + 1
    If n2 = 5 Then
        n2 = 1: k1 = k1 + m2 + 1: k2 = 1
    Else
        If n9 > 1 Then k2 = k2 + m2 + 1
    End If

    Cells(k1 + 1, k2 + 1).Select
    Cells(k1, k2 + 1).Value = n9
        
    i3 = 0
    For i1 = 1 To m2
        For i2 = 1 To m2
            i3 = i3 + 1
            Cells(k1 + i1, k2 + i2).Value = A1(i3)
        Next i2
    Next i1
    
    Return

'                          Exclude solutions with identical numbers in:
'                          rows (9), columns (9), main diagonals (2)

1800

'    Rows
    
     i1 = -8
     For i0 = 1 To 9
         i1 = i1 + 9
         b9(1) = A1(i1): b9(2) = A1(i1 + 1): b9(3) = A1(i1 + 2): b9(4) = A1(i1 + 3): b9(5) = A1(i1 + 4)
         b9(6) = A1(i1 + 5): b9(7) = A1(i1 + 6): b9(8) = A1(i1 + 7): b9(9) = A1(i1 + 8)
         GoSub 1860: If fl1 = 0 Then Return
     Next i0
   
'    Columns
    
     i1 = 0
     For i0 = 1 To 9
         i1 = i1 + 1
         b9(1) = A1(i1): b9(2) = A1(i1 + 9): b9(3) = A1(i1 + 18): b9(4) = A1(i1 + 27): b9(5) = A1(i1 + 36)
         b9(6) = A1(i1 + 45): b9(7) = A1(i1 + 54): b9(8) = A1(i1 + 63): b9(9) = A1(i1 + 72)
         GoSub 1860: If fl1 = 0 Then Return
     Next i0
    
'    Main Diagonals

     b9(1) = A1(1): b9(2) = A1(11): b9(3) = A1(21): b9(4) = A1(31): b9(5) = A1(41):
     b9(6) = A1(51): b9(7) = A1(61): b9(8) = A1(71): b9(9) = A1(81):
     GoSub 1860: If fl1 = 0 Then Return
     b9(1) = A1(9): b9(2) = A1(17): b9(3) = A1(25): b9(4) = A1(33): b9(5) = A1(41):
     b9(6) = A1(49): b9(7) = A1(57): b9(8) = A1(65): b9(9) = A1(73):
     GoSub 1860: If fl1 = 0 Then Return

     Return
    
'    Check identical numbers
    
1860 fl1 = 1
     For j10 = 1 To 9
        B2 = b9(j10)
        For j20 = (1 + j10) To 9
            If B2 = b9(j20) Then fl1 = 0: Return
        Next j20
     Next j10
     Return

End Sub

About the Author