About the Author

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

' Tested with Office 2007 under Windows 7

Sub SudSqrs8()

Dim a(6), b(6), c(6), d(3), s(3), z(3), A1(64), b8(8)

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

    Sheets("Klad1").Select
    t1 = Timer

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

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

For j1 = 2 To 65    '15
Cells(k1, 1).Value = j1

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

For j2 = 2 To 65    '27
Cells(k1 + 1, 1).Value = j2

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

For j3 = 2 To 65    '57
Cells(k1 + 2, 1).Value = j3

For i1 = 1 To 6
    c(i1) = Sheets("Constr8").Cells(j3, i1 + 14).Value
Next i1

'   Create A1()

    i3 = 0
    For j11 = 6 To 13 'Rows
    
        z(1) = Sheets("Constr8").Cells(j11, 1).Value
        z(2) = Sheets("Constr8").Cells(j11, 2).Value
        z(3) = Sheets("Constr8").Cells(j11, 3).Value
        
        For j12 = 5 To 12 'Columns
        
        s(1) = Sheets("Constr8").Cells(2, j12).Value
        s(2) = Sheets("Constr8").Cells(3, j12).Value
        s(3) = Sheets("Constr8").Cells(4, j12).Value
        
        d(3) = (a(1) * s(1) + a(2) * s(2) + a(3) * s(3) + a(4) * z(1) + a(5) * z(2) + a(6) * z(3)) Mod 2
        d(2) = (b(1) * s(1) + b(2) * s(2) + b(3) * s(3) + b(4) * z(1) + b(5) * z(2) + b(6) * z(3)) Mod 2
        d(1) = (c(1) * s(1) + c(2) * s(2) + c(3) * s(3) + c(4) * z(1) + c(5) * z(2) + c(6) * z(3)) Mod 2
        
        i3 = i3 + 1
        A1(i3) = 4 * d(3) + 2 * d(2) + d(1)
        
        Next j12
    
    Next j11

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

    GoSub 1800: If fl1 = 0 Then GoTo 30

    n9 = n9 + 1: GoSub 650    

30 Next j3
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 SudSqrs8")

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 (8), columns (8), main diagonals (2)

1800

'    Rows
    
     i1 = -7
     For i0 = 1 To 8
         i1 = i1 + 8
         b8(1) = A1(i1):     b8(2) = A1(i1 + 1): b8(3) = A1(i1 + 2): b8(4) = A1(i1 + 3):
         b8(5) = A1(i1 + 4): b8(6) = A1(i1 + 5): b8(7) = A1(i1 + 6): b8(8) = A1(i1 + 7)
         GoSub 1860: If fl1 = 0 Then Return
     Next i0

'    Columns
    
     i1 = 0
     For i0 = 1 To 8
         i1 = i1 + 1
         b8(1) = A1(i1):      b8(2) = A1(i1 + 8):  b8(3) = A1(i1 + 16): b8(4) = A1(i1 + 24):
         b8(5) = A1(i1 + 32): b8(6) = A1(i1 + 40): b8(7) = A1(i1 + 48): b8(8) = A1(i1 + 56)
         GoSub 1860: If fl1 = 0 Then Return
     Next i0

'    Main Diagonals

     b8(1) = A1(1): b8(2) = A1(10): b8(3) = A1(19): b8(4) = A1(28): 
     b8(5) = A1(37): b8(6) = A1(46): b8(7) = A1(55): b8(8) = A1(64)
     GoSub 1860: If fl1 = 0 Then Return
     b8(1) = A1(8): b8(2) = A1(15): b8(3) = A1(22): b8(4) = A1(29): 
     b8(5) = A1(36): b8(6) = A1(43): b8(7) = A1(50): b8(8) = A1(57)
     GoSub 1860: If fl1 = 0 Then Return
    
     Return
    
'    Check identical numbers
    
1860 fl1 = 1
     For j10 = 1 To 8
        B2 = b8(j10)
        For j20 = (1 + j10) To 8
            If B2 = b8(j20) Then fl1 = 0: Return
        Next j20
     Next j10
     Return

End Sub

About the Author