' 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

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
```