' Generates Sudoku Comparable Associated Compact Pan Magic Squares of order 9 for integers 0 thru 8
' Every third-row and third-column summing to s1/3
' Tested with Office 2007 under Windows 7
Sub SudSqr9a()
Dim a(81), b(9)
y = MsgBox("Locked", vbCritical, "Routine SudSqr9a")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 8: s1 = 36: s2 = s1 / 9
' Generate data
Sheets("Klad1").Select
t1 = Timer
a(41) = s2
For j81 = m1 To m2 'a(81)
a(81) = j81
a(1) = 2 * s2 - a(81)
For j80 = m1 To m2 'a(80)
a(80) = j80
a(79) = 3 * s2 - a(80) - a(81): If a(79) < m1 Or a(79) > m2 Then GoTo 800
a(3) = 2 * s2 - a(79): a(2) = 2 * s2 - a(80)
For j78 = m1 To m2 'a(78)
a(78) = j78
a(4) = 2 * s2 - a(78)
For j77 = m1 To m2 'a(77)
a(77) = j77
a(76) = 3 * s2 - a(77) - a(78): If a(76) < m1 Or a(76) > m2 Then GoTo 770
a(6) = 2 * s2 - a(76): a(5) = 2 * s2 - a(77)
For j75 = m1 To m2 'a(75)
a(75) = j75
a(7) = 2 * s2 - a(75)
For j74 = m1 To m2 'a(74)
a(74) = j74
a(73) = 3 * s2 - a(74) - a(75): If a(73) < m1 Or a(73) > m2 Then GoTo 740
a(44) = s2 + a(74) - a(80): If a(44) < m1 Or a(44) > m2 Then GoTo 740
a(9) = 2 * s2 - a(73): a(8) = 2 * s2 - a(74)
For j72 = m1 To m2 'a(72)
a(72) = j72
a(69) = a(72) + a(74) + a(75) - a(77) - 2 * a(78) + a(81): If a(69) < m1 Or a(69) > m2 Then GoTo 720
a(66) = a(72) + a(74) - a(80): If a(66) < m1 Or a(66) > m2 Then GoTo 720
a(63) = 3 * s2 - a(72) - a(81): If a(63) < m1 Or a(63) > m2 Then GoTo 720
a(60) = 3 * s2 - a(72) - a(74) - a(75) + a(77) + a(78) - a(81): If a(60) < m1 Or a(60) > m2 Then GoTo 720
a(57) = 3 * s2 - a(72) - a(74) - a(75) + a(80): If a(57) < m1 Or a(57) > m2 Then GoTo 720
a(52) = s2 - a(72) + a(77) + a(78) - 1 * a(81): If a(52) < m1 Or a(52) > m2 Then GoTo 720
a(49) = s2 - a(72) + a(80): If a(49) < m1 Or a(49) > m2 Then GoTo 720
a(46) = s2 - a(72) - a(74) - a(75) + a(77) + a(78) + a(80): If a(46) < m1 Or a(46) > m2 Then GoTo 720
a(10) = 2 * s2 - a(72)
For j71 = m1 To m2 'a(71)
a(71) = j71
a(70) = 3 * s2 - a(71) - a(72): If a(70) < m1 Or a(70) > m2 Then GoTo 710
a(68) = a(71) - a(74) + a(80): If a(68) < m1 Or a(68) > m2 Then GoTo 710
a(67) = 3 * s2 - a(71) - a(72) - a(75) + a(77) + 2 * a(78) - a(80) - a(81): If a(67) < m1 Or a(67) > m2 Then GoTo 710
a(65) = a(71) - 2 * a(74) + 2 * a(80): If a(65) < m1 Or a(65) > m2 Then GoTo 710
a(64) = 3 * s2 - a(71) - a(72) + a(74) - a(80): If a(64) < m1 Or a(64) > m2 Then GoTo 710
a(62) = 3 * s2 - a(71) - a(80): If a(62) < m1 Or a(62) > m2 Then GoTo 710
a(61) = -3 * s2 + a(71) + a(72) + a(80) + a(81): If a(61) < m1 Or a(61) > m2 Then GoTo 710
a(59) = 3 * s2 - a(71) + a(74) - a(77) - a(80): If a(59) < m1 Or a(59) > m2 Then GoTo 710
a(58) = -3 * s2 + a(71) + a(72) + a(75) - a(78) + a(80) + a(81): If a(58) < m1 Or a(58) > m2 Then GoTo 710
a(56) = 3 * s2 - a(71) + a(74) - 2 * a(80): If a(56) < m1 Or a(56) > m2 Then GoTo 710
a(55) = -3 * s2 + a(71) + a(72) + a(75) + a(80): If a(55) < m1 Or a(55) > m2 Then GoTo 710
a(54) = -2 * s2 + a(71) + a(72) - a(78) + a(80) + a(81): If a(54) < m1 Or a(54) > m2 Then GoTo 710
a(53) = 4 * s2 - a(71) - a(77) - a(80): If a(53) < m1 Or a(53) > m2 Then GoTo 710
a(51) = -2 * s2 + a(71) + a(72) + a(80): If a(51) < m1 Or a(51) > m2 Then GoTo 710
a(50) = 4 * s2 - a(71) - 2 * a(80): If a(50) < m1 Or a(50) > m2 Then GoTo 710
a(48) = -2 * s2 + a(71) + a(72) + a(75) - a(78) + a(80): If a(48) < m1 Or a(48) > m2 Then GoTo 710
a(47) = 4 * s2 - a(71) + a(74) - a(77) - 2 * a(80): If a(47) < m1 Or a(47) > m2 Then GoTo 710
a(45) = 4 * s2 - a(71) - 2 * a(72) - a(74) - a(75) + a(77) + 2 * a(78) - a(81): If a(45) < m1 Or a(45) > m2 Then GoTo 710
a(43) = -2 * s2 + a(71) + 2 * a(72) + a(75) - a(77) - 2 * a(78) + a(80) + a(81): If a(43) < m1 Or a(43) > m2 Then GoTo 710
a(42) = 4 * s2 - a(71) - 2 * a(72): If a(42) < m1 Or a(42) > m2 Then GoTo 710
a(40) = 2 * s2 - a(42): a(39) = 2 * s2 - a(43): a(38) = 2 * s2 - a(44): a(37) = 2 * s2 - a(45): a(36) = 2 * s2 - a(46):
a(35) = 2 * s2 - a(47): a(34) = 2 * s2 - a(48): a(33) = 2 * s2 - a(49): a(32) = 2 * s2 - a(50): a(31) = 2 * s2 - a(51):
a(30) = 2 * s2 - a(52): a(29) = 2 * s2 - a(53): a(28) = 2 * s2 - a(54): a(27) = 2 * s2 - a(55): a(26) = 2 * s2 - a(56):
a(25) = 2 * s2 - a(57): a(24) = 2 * s2 - a(58): a(23) = 2 * s2 - a(59): a(22) = 2 * s2 - a(60): a(21) = 2 * s2 - a(61):
a(20) = 2 * s2 - a(62): a(19) = 2 * s2 - a(63): a(18) = 2 * s2 - a(64): a(17) = 2 * s2 - a(65): a(16) = 2 * s2 - a(66):
a(15) = 2 * s2 - a(67): a(14) = 2 * s2 - a(68): a(13) = 2 * s2 - a(69): a(12) = 2 * s2 - a(70): a(11) = 2 * s2 - a(71):
' Exclude solutions with identical numbers in rows, columns, diagonals, sub squares (9)
GoSub 1800: If fl1 = 0 Then GoTo 710
n9 = n9 + 1
GoSub 2650 'Print results (squares)
' GoSub 2645 'Print results (selected numbers
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 SudSqr9a")
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
