' 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)

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