' Generates Sudoku Comparable Squares of order 8 for integers 0 thru 7
' Pan Magic, Complete, Partly Rectangular Compact (48 ea)
' The half rows sum to half the Magic Sum
' Tested with Office 2007 under Windows 7
Sub Sudoku8a()
Dim a(64), b(8)
y = MsgBox("Locked", vbCritical, "Routine Sudoku8a")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 7: s1 = 28
' Generate data
Sheets("Klad1").Select
t1 = Timer
For j64 = m1 To m2 'a(64)
a(64) = j64
For j63 = m1 To m2 'a(63)
If j63 = j64 Then GoTo 630
a(63) = j63
For j62 = m1 To m2 'a(62)
If j62 = j63 Or j62 = j64 Then GoTo 620
a(62) = j62
a(61) = s1 / 2 - a(62) - a(63) - a(64)
If a(61) < m1 Or a(61) > m2 Then GoTo 620
j61 = a(61)
If j61 = j62 Or j61 = j63 Or j61 = j64 Then GoTo 620 'a(61)
For j60 = m1 To m2 'a(60)
If j60 = j61 Or j60 = j62 Or j60 = j63 Or j60 = j64 Then GoTo 600
a(60) = j60
a(59) = 0.5 * s1 - a(60) - a(63) - a(64)
If a(59) < m1 Or a(59) > m2 Then GoTo 600
j59 = a(59)
If j59 = j60 Or j59 = j61 Or j59 = j62 Or j59 = j63 Or j59 = j64 Then GoTo 600
For j58 = m1 To m2 'a(58)
If j58 = j59 Or j58 = j60 Or j58 = j61 Or j58 = j62 Or j58 = j63 Or j58 = j64 Then GoTo 580
a(58) = j58
a(57) = -a(58) + a(63) + a(64)
If a(57) < m1 Or a(57) > m2 Then GoTo 580
j57 = a(57)
If j57 = j58 Or j57 = j59 Or j57 = j60 Or j57 = j61 Or j57 = j62 Or j57 = j63 Or j57 = j64 Then GoTo 580
For j56 = m1 To m2 'a(56)
If j56 = j64 Then GoTo 560
a(56) = j56
For j55 = m1 To m2 'a(55)
If j55 = j56 Then GoTo 550
If j55 = j63 Then GoTo 550
If j55 = j64 Then GoTo 550
a(55) = j55
For j54 = m1 To m2 'a(54)
If j54 = j55 Or j54 = j56 Then GoTo 540
If j54 = j62 Then GoTo 540
a(54) = j54
a(53) = 0.5 * s1 - a(54) - a(55) - a(56)
If a(53) < m1 Or a(53) > m2 Then GoTo 540
j53 = a(53)
If j53 = j54 Or j53 = j55 Or j53 = j56 Then GoTo 540
If j53 = j61 Then GoTo 540
For j52 = m1 To m2 'a(52)
If j52 = j53 Or j52 = j54 Or j52 = j55 Or j52 = j56 Then GoTo 520
If j52 = j60 Then GoTo 520
a(52) = j52
a(51) = 0.5 * s1 - a(52) - a(55) - a(56)
If a(51) < m1 Or a(51) > m2 Then GoTo 520
j51 = a(51)
If j51 = j52 Or j51 = j53 Or j51 = j54 Or j51 = j55 Or j51 = j56 Then GoTo 520
If j51 = j59 Then GoTo 520
a(50) = a(52) - a(54) + a(56) - a(58) + a(60) - a(62) + a(64)
If a(50) < m1 Or a(50) > m2 Then GoTo 520
j50 = a(50)
If j50 = j51 Or j50 = j52 Or j50 = j53 Or j50 = j54 Or j50 = j55 Or j50 = j56 Then GoTo 520
If j50 = j58 Then GoTo 520
a(49) = -a(52) + a(54) + a(55) + a(58) - a(60) + a(62) - a(64)
If a(49) < m1 Or a(49) > m2 Then GoTo 520
j49 = a(49)
If j49 = j50 Or j49 = j51 Or j49 = j52 Or j49 = j53 Or j49 = j54 Or j49 = j55 Or j49 = j56 Then GoTo 520
If j49 = j57 Then GoTo 520
For j48 = m1 To m2 'a(48)
If j48 = j56 Or j48 = j64 Then GoTo 480
a(48) = j48
For j47 = m1 To m2 'a(47)
If j47 = j48 Then GoTo 470
If j47 = j55 Or j47 = j63 Then GoTo 470
a(47) = j47
For j46 = m1 To m2 'a(46)
If j46 = j47 Or j46 = j48 Then GoTo 460
If j46 = j54 Or j46 = j62 Then GoTo 460
If j46 = j55 Or j46 = j64 Then GoTo 460
a(46) = j46
a(45) = 0.5 * s1 - a(46) - a(47) - a(48)
If a(45) < m1 Or a(45) > m2 Then GoTo 460
j45 = a(45)
If j45 = j46 Or j45 = j47 Or j45 = j48 Then GoTo 460
If j45 = j53 Or j45 = j61 Then GoTo 460
For j44 = m1 To m2 'a(44)
If j44 = j45 Or j44 = j46 Or j44 = j47 Or j44 = j48 Then GoTo 440
If j44 = j52 Or j44 = j60 Then GoTo 440
a(44) = j44
a(43) = 0.5 * s1 - a(44) - a(47) - a(48)
If a(43) < m1 Or a(43) > m2 Then GoTo 440
j43 = a(43)
If j43 = j44 Or j43 = j45 Or j43 = j46 Or j43 = j47 Or j43 = j48 Then GoTo 440
If j43 = j51 Or j43 = j59 Then GoTo 440
If j43 = j50 Or j43 = j57 Then GoTo 440
For j42 = m1 To m2 'a(42)
If j42 = j43 Or j42 = j44 Or j42 = j45 Or j42 = j46 Or j42 = j47 Or j42 = j48 Then GoTo 420
If j42 = j50 Or j42 = j58 Then GoTo 420
a(42) = j42
a(41) = -a(42) + a(47) + a(48)
If a(41) < m1 Or a(41) > m2 Then GoTo 420
j41 = a(41)
If j41 = j42 Or j41 = j43 Or j41 = j44 Or j41 = j45 Or j41 = j46 Or j41 = j47 Or j41 = j48 Then GoTo 420
If j41 = j49 Or j41 = j57 Then GoTo 420
For j40 = m1 To m2 'a(40)
If j40 = j48 Or j40 = j56 Or j40 = j64 Then GoTo 400
a(40) = j40
a(39) = s1 - a(40) - a(47) - a(48) - a(55) - a(56) - a(63) - a(64)
If a(39) < m1 Or a(39) > m2 Then GoTo 400
a(38) = a(40) - a(46) + a(48) - a(54) + a(56) - a(62) + a(64)
If a(38) < m1 Or a(38) > m2 Then GoTo 400
a(37) = -0.5 * s1 - a(40) + a(46) + a(47) + a(54) + a(55) + a(62) + a(63)
If a(37) < m1 Or a(37) > m2 Then GoTo 400
a(36) = a(40) - a(44) + a(48) - a(52) + a(56) - a(60) + a(64)
If a(36) < m1 Or a(36) > m2 Then GoTo 400
a(35) = -0.5 * s1 - a(40) + a(44) + a(47) + a(52) + a(55) + a(60) + a(63)
If a(35) < m1 Or a(35) > m2 Then GoTo 400
a(34) = a(40) - a(42) + a(48) - a(52) + a(54) - a(60) + a(62)
If a(34) < m1 Or a(34) > m2 Then GoTo 400
a(33) = s1 - a(40) + a(42) - a(47) - 2 * a(48) + a(52) - a(54) - a(55) - a(56) + a(60) - a(62) - a(63) - a(64)
If a(33) < m1 Or a(33) > m2 Then GoTo 400
a(32) = s1 / 4 - a(60): a(31) = s1 / 4 - a(59): a(30) = s1 / 4 - a(58): a(29) = s1 / 4 - a(57)
a(28) = s1 / 4 - a(64): a(27) = s1 / 4 - a(63): a(26) = s1 / 4 - a(62): a(25) = s1 / 4 - a(61)
a(24) = s1 / 4 - a(52): a(23) = s1 / 4 - a(51): a(22) = s1 / 4 - a(50): a(21) = s1 / 4 - a(49)
a(20) = s1 / 4 - a(56): a(19) = s1 / 4 - a(55): a(18) = s1 / 4 - a(54): a(17) = s1 / 4 - a(53)
a(16) = s1 / 4 - a(44): a(15) = s1 / 4 - a(43): a(14) = s1 / 4 - a(42): a(13) = s1 / 4 - a(41)
a(12) = s1 / 4 - a(48): a(11) = s1 / 4 - a(47): a(10) = s1 / 4 - a(46): a(9) = s1 / 4 - a(45)
a(8) = s1 / 4 - a(36): a(7) = s1 / 4 - a(35): a(6) = s1 / 4 - a(34): a(5) = s1 / 4 - a(33)
a(4) = s1 / 4 - a(40): a(3) = s1 / 4 - a(39): a(2) = s1 / 4 - a(38): a(1) = s1 / 4 - a(37)
' Exclude solutions with identical numbers in:
' rows (8), columns (8), main diagonals (2)
GoSub 1800: If fl1 = 0 Then GoTo 400
n9 = n9 + 1
' GoSub 2650 'Print results (squares)
GoSub 2645 'Print results (selected numbers)
400 Next j40
420 Next j42
440 Next j44
460 Next j46
470 Next j47
480 Next j48
520 Next j52
540 Next j54
550 Next j55
560 Next j56
580 Next j58
600 Next j60
620 Next j62
630 Next j63
640 Next j64
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine Sudoku8a")
End
' 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
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)
GoSub 1860: If fl1 = 0 Then Return
Next i0
' Columns
i1 = 0
For i0 = 1 To 8
i1 = i1 + 1
b(1) = a(i1): b(2) = a(i1 + 8): b(3) = a(i1 + 16): b(4) = a(i1 + 24):
b(5) = a(i1 + 32): b(6) = a(i1 + 40): b(7) = a(i1 + 48): b(8) = a(i1 + 56)
GoSub 1860: If fl1 = 0 Then Return
Next i0
' Main Diagonals
b(1) = a(1): b(2) = a(10): b(3) = a(19): b(4) = a(28): b(5) = a(37): b(6) = a(46): b(7) = a(55): b(8) = a(64)
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(8): b(2) = a(15): b(3) = a(22): b(4) = a(29): b(5) = a(36): b(6) = a(43): b(7) = a(50): b(8) = a(57)
GoSub 1860: If fl1 = 0 Then Return
Return
' Sudoku Comparable Rectangles (Optional)
' Base Rectangles (2 x 4)
b(1) = a(1): b(2) = a(2): b(3) = a(9): b(4) = a(10): b(5) = a(17): b(6) = a(18): b(7) = a(25): b(8) = a(26):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(3): b(2) = a(4): b(3) = a(11): b(4) = a(12): b(5) = a(19): b(6) = a(20): b(7) = a(27): b(8) = a(28):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(5): b(2) = a(6): b(3) = a(13): b(4) = a(14): b(5) = a(21): b(6) = a(22): b(7) = a(29): b(8) = a(30):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(7): b(2) = a(8): b(3) = a(15): b(4) = a(16): b(5) = a(23): b(6) = a(24): b(7) = a(31): b(8) = a(32):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(33): b(2) = a(34): b(3) = a(41): b(4) = a(42): b(5) = a(49): b(6) = a(50): b(7) = a(57): b(8) = a(58):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(35): b(2) = a(36): b(3) = a(43): b(4) = a(44): b(5) = a(51): b(6) = a(52): b(7) = a(59): b(8) = a(60):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(37): b(2) = a(38): b(3) = a(45): b(4) = a(46): b(5) = a(53): b(6) = a(54): b(7) = a(61): b(8) = a(62):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(39): b(2) = a(40): b(3) = a(47): b(4) = a(48): b(5) = a(55): b(6) = a(56): b(7) = a(63): b(8) = a(64):
GoSub 1860: If fl1 = 0 Then Return
' Intersection Rectangles (2 x 4)
b(1) = a(2): b(2) = a(3): b(3) = a(10): b(4) = a(11): b(5) = a(18): b(6) = a(19): b(7) = a(26): b(8) = a(27):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(4): b(2) = a(5): b(3) = a(12): b(4) = a(13): b(5) = a(20): b(6) = a(21): b(7) = a(28): b(8) = a(29):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(6): b(2) = a(7): b(3) = a(14): b(4) = a(15): b(5) = a(22): b(6) = a(23): b(7) = a(30): b(8) = a(31):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(1): b(2) = a(8): b(3) = a(9): b(4) = a(16): b(5) = a(17): b(6) = a(24): b(7) = a(25): b(8) = a(32):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(34): b(2) = a(35): b(3) = a(42): b(4) = a(43): b(5) = a(50): b(6) = a(51): b(7) = a(58): b(8) = a(59):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(36): b(2) = a(37): b(3) = a(44): b(4) = a(45): b(5) = a(52): b(6) = a(53): b(7) = a(60): b(8) = a(61):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(38): b(2) = a(39): b(3) = a(46): b(4) = a(47): b(5) = a(54): b(6) = a(55): b(7) = a(62): b(8) = a(63):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(33): b(2) = a(40): b(3) = a(41): b(4) = a(48): b(5) = a(49): b(6) = a(56): b(7) = a(57): b(8) = a(64):
GoSub 1860: If fl1 = 0 Then Return
' Sub Squares Border Rectangles (2 x 4)
b(1) = a(1): b(2) = a(4): b(3) = a(9): b(4) = a(12): b(5) = a(17): b(6) = a(20): b(7) = a(25): b(8) = a(28):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(5): b(2) = a(8): b(3) = a(13): b(4) = a(16): b(5) = a(21): b(6) = a(24): b(7) = a(29): b(8) = a(32):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(33): b(2) = a(36): b(3) = a(41): b(4) = a(44): b(5) = a(49): b(6) = a(52): b(7) = a(57): b(8) = a(60):
GoSub 1860: If fl1 = 0 Then Return
b(1) = a(37): b(2) = a(40): b(3) = a(45): b(4) = a(48): b(5) = a(53): b(6) = a(56): b(7) = a(61): b(8) = a(64):
GoSub 1860: If fl1 = 0 Then Return
Return
' Check identical numbers
1860 fl1 = 1
For j10 = 1 To 8
b2 = b(j10)
For j20 = (1 + j10) To 8
If b2 = b(j20) Then fl1 = 0: Return
Next j20
Next j10
Return
' Print results (selected numbers)
2645 For i1 = 1 To 64
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 64).Select
Return
' Print results (squares)
2650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 9: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 9
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
i3 = 0
For i1 = 1 To 8
For i2 = 1 To 8
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
