' Generates Sudoku Comparable Associated Magic Squares of order 9 for integers 0 thru 8
' Each third-row and third-column summing to s1/3
' Tested with Office 2007 under Windows 7
Sub SudSqr9b()
Dim a(81), b(9)
y = MsgBox("Locked", vbCritical, "Routine SudSqr9b")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 8: s1 = 36: s2 = s1 / 9
' s2 is center (= 4)
Sheets("Klad1").Select
t1 = Timer
a(41) = s2
' Row 1
For j81 = m1 To m2 'a(81)
a(81) = j81
For j80 = m1 To m2 'a(80)
a(80) = j80
If a(80) = a(81) Then GoTo 800
a(79) = 3 * s2 - a(80) - a(81):
If a(79) < m1 Or a(79) > m2 Then GoTo 800
If a(79) = a(80) Or a(79) = a(81) Then GoTo 800
For j78 = m1 To m2 'a(78)
a(78) = j78
If a(78) = a(79) Or a(78) = a(80) Or a(78) = a(81) Then GoTo 780
For j77 = m1 To m2 'a(77)
a(77) = j77
If a(77) = a(78) Or a(77) = a(79) Or a(77) = a(80) Or a(77) = a(81) Then GoTo 770
If a(77) = a(41) Then GoTo 770
a(76) = 3 * s2 - a(77) - a(78):
If a(76) < m1 Or a(76) > m2 Then GoTo 770
If a(76) = a(77) Or a(76) = a(78) Or a(76) = a(79) Or a(76) = a(80) Or a(76) = a(81) Then GoTo 770
For j75 = m1 To m2 'a(75)
a(75) = j75
If a(75) = a(77) Or a(75) = a(78) Or a(75) = a(79) Or a(75) = a(80) Or a(75) = a(81) Then GoTo 750
If a(75) = a(76) Then GoTo 750
For j74 = m1 To m2 'a(74)
a(74) = j74
If a(74) = a(77) Or a(74) = a(78) Or a(74) = a(79) Or a(74) = a(80) Or a(74) = a(81) Then GoTo 740
If a(74) = a(75) Or a(74) = a(76) Then GoTo 740
a(73) = 3 * s2 - a(74) - a(75):
If a(73) < m1 Or a(73) > m2 Then GoTo 740
If a(73) = a(77) Or a(73) = a(78) Or a(73) = a(79) Or a(73) = a(80) Or a(73) = a(81) Then GoTo 740
If a(73) = a(74) Or a(73) = a(75) Or a(73) = a(76) Then GoTo 740
For i1 = 1 To 9: a(i1) = 2 * s2 - a(82 - i1): Next i1
For i1 = 1 To 9
If a(i1) = a(i1 + 72) Then GoTo 740
Next i1
' Row 2
For j72 = m1 To m2 'a(72)
a(72) = j72
If a(72) = a(81) Or a(72) = a(9) Then GoTo 720
a(10) = 2 * s2 - a(72):
For j71 = m1 To m2 'a(71)
a(71) = j71
If a(71) = a(80) Or a(71) = a(8) Then GoTo 710
If a(71) = a(72) Then GoTo 710
If a(71) = a(81) Or a(71) = a(1) Then GoTo 710
a(70) = 3 * s2 - a(71) - a(72):
If a(70) < m1 Or a(70) > m2 Then GoTo 710
If a(70) = a(79) Or a(70) = a(7) Then GoTo 710
If a(70) = a(71) Or a(70) = a(72) Then GoTo 710
a(12) = 2 * s2 - a(70):
a(11) = 2 * s2 - a(71):
For j69 = m1 To m2 'a(69)
a(69) = j69
If a(69) = a(78) Or a(69) = a(6) Then GoTo 690
If a(69) = a(70) Or a(69) = a(71) Or a(69) = a(72) Then GoTo 690
a(13) = 2 * s2 - a(69):
For j68 = m1 To m2 'a(68)
a(68) = j68
If a(68) = a(77) Or a(68) = a(41) Or a(68) = a(5) Then GoTo 680
If a(68) = a(69) Or a(68) = a(70) Or a(68) = a(71) Or a(68) = a(72) Then GoTo 680
a(67) = 3 * s2 - a(68) - a(69):
If a(67) < m1 Or a(67) > m2 Then GoTo 680
If a(67) = a(76) Or a(67) = a(13) Or a(67) = a(4) Then GoTo 680
If a(67) = a(68) Or a(67) = a(69) Or a(67) = a(70) Or a(67) = a(71) Or a(67) = a(72) Then GoTo 680
a(14) = 2 * s2 - a(68):
a(15) = 2 * s2 - a(67):
For j66 = m1 To m2 'a(66)
a(66) = j66
If a(66) = a(75) Or a(66) = a(12) Or a(66) = a(3) Then GoTo 660
If a(66) = a(68) Or a(66) = a(69) Or a(66) = a(70) Or a(66) = a(71) Or a(66) = a(72) Then GoTo 660
If a(66) = a(67) Then GoTo 660
a(16) = 2 * s2 - a(66):
For j65 = m1 To m2 'a(65)
a(65) = j65
If a(65) = a(74) Or a(65) = a(11) Or a(65) = a(2) Then GoTo 650
If a(65) = a(68) Or a(65) = a(69) Or a(65) = a(70) Or a(65) = a(71) Or a(65) = a(72) Then GoTo 650
If a(65) = a(66) Or a(65) = a(67) Then GoTo 650
If a(65) = a(73) Or a(65) = a(9) Then GoTo 650
a(64) = 3 * s2 - a(65) - a(66):
If a(64) < m1 Or a(64) > m2 Then GoTo 650
If a(64) = a(73) Or a(64) = a(10) Or a(64) = a(1) Then GoTo 650
If a(64) = a(68) Or a(64) = a(69) Or a(64) = a(70) Or a(64) = a(71) Or a(64) = a(72) Then GoTo 650
If a(64) = a(65) Or a(64) = a(66) Or a(64) = a(67) Then GoTo 650
a(17) = 2 * s2 - a(65):
a(18) = 2 * s2 - a(64):
For i1 = 10 To 18
If a(i1) = a(i1 - 1) Then GoTo 650
If a(i1) = a(i1 + 54) Then GoTo 650
If a(i1) = a(i1 + 63) Then GoTo 650
Next i1
' Row 3
a(63) = s1 / 3 - a(72) - a(81)
If a(63) < m1 Or a(63) > m2 Then GoTo 650
a(62) = s1 / 3 - a(71) - a(80)
If a(62) < m1 Or a(62) > m2 Then GoTo 650
a(61) = -s1 / 3 + a(71) + a(72) + a(80) + a(81)
If a(61) < m1 Or a(61) > m2 Then GoTo 650
If a(61) = a(81) Or a(61) = a(71) Or a(61) = a(11) Or a(61) = a(1) Then GoTo 650
a(60) = s1 / 3 - a(69) - a(78)
If a(60) < m1 Or a(60) > m2 Then GoTo 650
a(59) = s1 / 3 - a(68) - a(77)
If a(59) < m1 Or a(59) > m2 Then GoTo 650
If a(59) = a(41) Then GoTo 650
a(58) = -s1 / 3 + a(68) + a(69) + a(77) + a(78)
If a(58) < m1 Or a(58) > m2 Then GoTo 650
a(57) = s1 / 3 - a(66) - a(75)
If a(57) < m1 Or a(57) > m2 Then GoTo 650
If a(57) = a(73) Or a(57) = a(65) Or a(57) = a(17) Or a(57) = a(9) Then GoTo 650
a(56) = s1 / 3 - a(65) - a(74)
If a(56) < m1 Or a(56) > m2 Then GoTo 650
a(55) = -s1 / 3 + a(65) + a(66) + a(74) + a(75)
If a(55) < m1 Or a(55) > m2 Then GoTo 650
b(1) = a(55): b(2) = a(56): b(3) = a(57): b(4) = a(58): b(5) = a(59): b(6) = a(60): b(7) = a(61): b(8) = a(62): b(9) = a(63):
GoSub 1860: If fl1 = 0 Then GoTo 650
For i1 = 55 To 63
If a(i1) = a(i1 - 54) Then GoTo 650
If a(i1) = a(i1 - 45) Then GoTo 650
If a(i1) = a(i1 + 9) Then GoTo 650
If a(i1) = a(i1 + 18) Then GoTo 650
Next i1
For i1 = 1 To 9: a(i1 + 18) = 2 * s2 - a(64 - i1): Next i1
For i1 = 19 To 27
If a(i1) = a(i1 - 18) Then GoTo 650
If a(i1) = a(i1 - 9) Then GoTo 650
If a(i1) = a(i1 + 36) Then GoTo 650
If a(i1) = a(i1 + 45) Then GoTo 650
If a(i1) = a(i1 + 54) Then GoTo 650
Next i1
' Row 4
For j54 = m1 To m2 'a(54)
a(54) = j54
For j53 = m1 To m2 'a(53)
a(53) = j53
a(52) = s1 / 3 - a(53) - a(54)
If a(52) < m1 Or a(52) > m2 Then GoTo 530
For j51 = m1 To m2 'a(51)
a(51) = j51
For j50 = m1 To m2 'a(50)
a(50) = j50
a(49) = s1 / 3 - a(50) - a(51)
If a(49) < m1 Or a(49) > m2 Then GoTo 500
For j48 = m1 To m2 'a(48)
a(48) = j48
For j47 = m1 To m2 'a(47)
a(47) = j47
a(46) = s1 / 3 - a(47) - a(48)
If a(46) < m1 Or a(46) > m2 Then GoTo 470
b(1) = a(46): b(2) = a(47): b(3) = a(48): b(4) = a(49): b(5) = a(50): b(6) = a(51): b(7) = a(52): b(8) = a(53): b(9) = a(54):
GoSub 1860: If fl1 = 0 Then GoTo 470
For i1 = 46 To 54
If a(i1) = a(i1 - 45) Then GoTo 470
If a(i1) = a(i1 - 36) Then GoTo 470
If a(i1) = a(i1 - 27) Then GoTo 470
If a(i1) = a(i1 + 9) Then GoTo 470
If a(i1) = a(i1 + 18) Then GoTo 470
If a(i1) = a(i1 + 27) Then GoTo 470
Next i1
For i1 = 1 To 9
a(i1 + 27) = 2 * s2 - a(55 - i1)
Next i1
For i1 = 28 To 36
If a(i1) = a(i1 - 27) Then GoTo 470
If a(i1) = a(i1 - 18) Then GoTo 470
If a(i1) = a(i1 - 9) Then GoTo 470
If a(i1) = a(i1 + 18) Then GoTo 470
If a(i1) = a(i1 + 27) Then GoTo 470
If a(i1) = a(i1 + 36) Then GoTo 470
If a(i1) = a(i1 + 45) Then GoTo 470
Next i1
b(1) = a(73): b(2) = a(65): b(3) = a(57): b(4) = a(49): b(5) = a(41): b(6) = a(33): b(7) = a(25): b(8) = a(17): b(9) = a(9):
GoSub 1860: If fl1 = 0 Then GoTo 470
b(1) = a(81): b(2) = a(71): b(3) = a(61): b(4) = a(51): b(5) = a(41): b(6) = a(31): b(7) = a(21): b(8) = a(11): b(9) = a(1):
GoSub 1860: If fl1 = 0 Then GoTo 470
' Row 5
a(45) = 16 - a(47) - a(48) - a(54)
If a(45) < m1 Or a(45) > m2 Then GoTo 470
a(44) = 4 + a(47) - a(53)
If a(44) < m1 Or a(44) > m2 Then GoTo 470
a(43) = -8 + a(48) + a(53) + a(54)
If a(43) < m1 Or a(43) > m2 Then GoTo 470
a(42) = 16 - a(50) - 2 * a(51)
If a(42) < m1 Or a(42) > m2 Then GoTo 470
For i1 = 1 To 4
a(i1 + 36) = 2 * s2 - a(46 - i1)
Next i1
' Exclude solutions with identical numbers in rows, columns, diagonals, sub squares (9)
GoSub 1800: If fl1 = 0 Then GoTo 470
n9 = n9 + 1
' Cells(1, 1).Value = n9 'Counting
' GoSub 2650 'Print results (squares)
GoSub 2645 'Print results (selected numbers
470 Next j47
480 Next j48
500 Next j50
510 Next j51
530 Next j53
540 Next j54
650 Next j65
660 Next j66
680 Next j68
690 Next j69
710 Next j71
720 Next j72
740 Next j74
750 Next j75
770 Next j77
780 Next j78
800 Next j80
810 Next j81
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine SudSqr9b")
End
' Exclude solutions with identical numbers in rows, columns, diagonals, sub squares (9)
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
' Sub Squares 3 x 3
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
1860 fl1 = 1
For j1 = 1 To 9
b2 = b(j1)
For j2 = (1 + j1) To 9
If b2 = b(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
' Print results (selected numbers)
2645 For i1 = 1 To 81
Cells(n9, i1).Value = a(i1)
Next i1
Return
' Print results (squares)
2650 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 = CStr(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
