' Generates Sudoku Comparable Squares of order 9 based on Ternary Squares

' Tested with Office 2007 under Windows 7

```Sub CnstrSqrs9b()

Dim b1(2, 81), a(81), b(9)

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

n4 = 3456 			 'Base Case    : 3456
'Solutions962 :   24

n2 = 0: n9 = 0: k1 = 1: k2 = 1
s1 = 36

t1 = Timer

For j1 = 2 To n4 + 1

Cells(n9 + 1, 82).Select: Cells(n9 + 1, 82).Value = j1

For j2 = 2 To n4 + 1
If j2 = j1 Then GoTo 20

j10 = j1: j20 = 1: GoSub 100                 'Read Ternary Square 1
j10 = j2: j20 = 2: GoSub 100                 'Read Ternary Square 2

For j4 = 1 To 81
a(j4) = b1(1, j4) + 3 * b1(2, j4)
Next j4

GoSub 1800: If fl1 = 0 Then GoTo 20          'Check identical numbers
'in rows, columns, main diagonals and sub squares

n9 = n9 + 1: GoSub 740                       'Print results (selected numbers)
'       n9 = n9 + 1: GoSub 750                       'Print results (squares)

20  Next j2

Next j1

t2 = Timer

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

End

'   Read Ternary Squares (Line Format)

100 For i1 = 1 To 81
b1(j20, i1) = Sheets("Input962").Cells(j10, i1).Value
Next i1
Return

'   Check identical numbers
'   in rows, columns, main diagonals and sub squares (partly compact only)

1800 fl1 = 1
'    Rows

i1 = -8
For i0 = 1 To 9
i1 = i1 + 9
b(1) = a(i1): b(2) = a(i1 + 1): b(3) = a(i1 + 2): b(4) = a(i1 + 3): b(5) = a(i1 + 4)
b(6) = a(i1 + 5): b(7) = a(i1 + 6): b(8) = a(i1 + 7): b(9) = a(i1 + 8)
GoSub 1860: If fl1 = 0 Then Return
Next i0

'    Columns

i1 = 0
For i0 = 1 To 9
i1 = i1 + 1
b(1) = a(i1): b(2) = a(i1 + 9): b(3) = a(i1 + 18): b(4) = a(i1 + 27): b(5) = a(i1 + 36)
b(6) = a(i1 + 45): b(7) = a(i1 + 54): b(8) = a(i1 + 63): b(9) = a(i1 + 72)
GoSub 1860: If fl1 = 0 Then Return
Next i0

'    Main Diagonals

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

Return

'    Sub Squares 3 x 3 (Optional)

b(1) = a(1): b(2) = a(2): b(3) = a(3): b(4) = a(10): b(5) = a(11): b(6) = a(12): b(7) = a(19): b(8) = a(20): b(9) = a(21):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(4): b(2) = a(5): b(3) = a(6): b(4) = a(13): b(5) = a(14): b(6) = a(15): b(7) = a(22): b(8) = a(23): b(9) = a(24):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(7): b(2) = a(8): b(3) = a(9): b(4) = a(16): b(5) = a(17): b(6) = a(18): b(7) = a(25): b(8) = a(26): b(9) = a(27):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(28): b(2) = a(29): b(3) = a(30): b(4) = a(37): b(5) = a(38): b(6) = a(39): b(7) = a(46): b(8) = a(47): b(9) = a(48):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(31): b(2) = a(32): b(3) = a(33): b(4) = a(40): b(5) = a(41): b(6) = a(42): b(7) = a(49): b(8) = a(50): b(9) = a(51):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(34): b(2) = a(35): b(3) = a(36): b(4) = a(43): b(5) = a(44): b(6) = a(45): b(7) = a(52): b(8) = a(53): b(9) = a(54):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(55): b(2) = a(56): b(3) = a(57): b(4) = a(64): b(5) = a(65): b(6) = a(66): b(7) = a(73): b(8) = a(74): b(9) = a(75):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(58): b(2) = a(59): b(3) = a(60): b(4) = a(67): b(5) = a(68): b(6) = a(69): b(7) = a(76): b(8) = a(77): b(9) = a(78):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(61): b(2) = a(62): b(3) = a(63): b(4) = a(70): b(5) = a(71): b(6) = a(72): b(7) = a(79): b(8) = a(80): b(9) = a(81):
GoSub 1860: If fl1 = 0 Then Return

Return

'    Sub Squares Partly Compact (Optional)

'    Sub Squares 3 x 3 (left to right)

For i1 = 1 To 3        'Check 27 Squares
i22 = (i1 - 1) * 27
For i2 = 1 To 9
i11 = i2:
i12 = (i11 + 1) Mod 9: If i12 = 0 Then i12 = 9
i13 = (i12 + 1) Mod 9: If i13 = 0 Then i13 = 9

b(1) = a(i22 + i11):      b(2) = a(i22 + i12):      b(3) = a(i22 + i13)
b(4) = a(i22 + i11 + 9):  b(5) = a(i22 + i12 + 9):  b(6) = a(i22 + i13 + 9)
b(7) = a(i22 + i11 + 18): b(8) = a(i22 + i12 + 18): b(9) = a(i22 + i13 + 18)
GoSub 1860: If fl1 = 0 Then Return
Next i2
Next i1

'    Sub Squares 3 x 3 (top to bottom)

For i1 = 1 To 5       'Check 12 Squares
If i1 <> 3 Then
i22 = 9 + (i1 - 1) * 9
For i2 = 1 To 9 Step 3
i11 = i2:
i12 = (i11 + 1) Mod 9: If i12 = 0 Then i12 = 9
i13 = (i12 + 1) Mod 9: If i13 = 0 Then i13 = 9

b(1) = a(i22 + i11):      b(2) = a(i22 + i12):      b(3) = a(i22 + i13)
b(4) = a(i22 + i11 + 9):  b(5) = a(i22 + i12 + 9):  b(6) = a(i22 + i13 + 9)
b(7) = a(i22 + i11 + 18): b(8) = a(i22 + i12 + 18): b(9) = a(i22 + i13 + 18)
GoSub 1860: If fl1 = 0 Then Return
Next i2
End If
Next i1

'    Check 6 Squares

b(1) = a(64): b(2) = a(65): b(3) = a(66): b(4) = a(73): b(5) = a(74): b(6) = a(75): b(7) = a(1): b(8) = a(2): b(9) = a(3):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(67): b(2) = a(68): b(3) = a(69): b(4) = a(76): b(5) = a(77): b(6) = a(78): b(7) = a(4): b(8) = a(5): b(9) = a(6):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(70): b(2) = a(71): b(3) = a(72): b(4) = a(79): b(5) = a(80): b(6) = a(81): b(7) = a(7): b(8) = a(8): b(9) = a(9):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(73): b(2) = a(74): b(3) = a(75): b(4) = a(1): b(5) = a(2): b(6) = a(3): b(7) = a(10): b(8) = a(11): b(9) = a(12):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(76): b(2) = a(77): b(3) = a(78): b(4) = a(4): b(5) = a(5): b(6) = a(6): b(7) = a(13): b(8) = a(14): b(9) = a(15):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(79): b(2) = a(80): b(3) = a(81): b(4) = a(7): b(5) = a(8): b(6) = a(9): b(7) = a(16): b(8) = a(17): b(9) = a(18):
GoSub 1860: If fl1 = 0 Then Return

Return

'    Check identical numbers

1860 fl1 = 1
For j10 = 1 To 9
b2 = b(j10)
For j20 = (1 + j10) To 9
If b2 = b(j20) Then fl1 = 0: Return
Next j20
Next j10
Return

'   Print results (selected numbers)

740 Cells(n9, 81).Select
For i1 = 1 To 81
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 82).Value = j1
Cells(n9, 83).Value = j2
Return

'   Print results (squares)

750 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 10: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 10
End If

Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9

i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1

Return

End Sub
```