' 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)
Sheets("Klad1").Select
y = MsgBox("Locked", vbCritical, "Routine CnstrSqrs9b")
End
n4 = 3456 'Base Case : 3456
'Solutions962 : 24
'Solutions966 : 24
'Solutions968 : 96
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
Return 'Option: Check 27 out of 45
' 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
