' Generates Associated Magic Squares of order 9, Quadrant (P1 ... P7) Magic
' Based on Pre Constructed Generators
' Tested with Office 365 under Windows 10
Sub MgcSqr98a()
Dim a(81), b(83), c(81), m(9)
y = MsgBox("Locked", vbCritical, "Routine MgcSqr98a")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 83: s1 = 378: Pr9 = 2 * s1 / 9
' Generate data
Sheets("Klad1").Select
t1 = Timer
For j100 = 36 To 36
Cells(2, 1).Value = j100
' Read Partly Completed Associated Squares
Erase a, b
For i1 = 1 To 9 'Read Line 1
a(i1) = Sheets("PrtLns9").Cells(j100, i1).Value
If a(i1) <> 0 Then b(a(i1)) = a(i1)
Next i1
For i1 = 73 To 81 'Read Line 9
a(i1) = Sheets("PrtLns9").Cells(j100, i1).Value
If a(i1) <> 0 Then b(a(i1)) = a(i1)
Next i1
For i1 = 64 To 72 'Read Line 8
m(i1 - 63) = Sheets("PrtLns9").Cells(j100, i1).Value
Next i1
a(41) = 42: b(a(41)) = a(41):
For j72 = m(9) To m(9) '' m1 To m2 'a(72)
If b(j72) = 0 Then b(j72) = j72: c(72) = j72 Else GoTo 720
a(72) = j72
a(10) = Pr9 - a(72): If b(a(10)) = 0 Then b(a(10)) = a(10): c(10) = a(10) Else GoTo 100
For j71 = m(8) To m(8) '' m1 To m2 'a(71)
If b(j71) = 0 Then b(j71) = j71: c(71) = j71 Else GoTo 710
a(71) = j71
a(11) = Pr9 - a(71): If b(a(11)) = 0 Then b(a(11)) = a(11): c(11) = a(11) Else GoTo 110
For j70 = m(7) To m(7) '' m1 To m2 'a(70)
If b(j70) = 0 Then b(j70) = j70: c(70) = j70 Else GoTo 700
a(70) = j70
a(12) = Pr9 - a(70): If b(a(12)) = 0 Then b(a(12)) = a(12): c(12) = a(12) Else GoTo 120
For j69 = m(6) To m(6) '' m1 To m2 'a(69)
If b(j69) = 0 Then b(j69) = j69: c(69) = j69 Else GoTo 690
a(69) = j69
a(13) = Pr9 - a(69): If b(a(13)) = 0 Then b(a(13)) = a(13): c(13) = a(13) Else GoTo 130
For j68 = m(5) To m(5) '' m1 To m2 'a(68)
If b(j68) = 0 Then b(j68) = j68: c(68) = j68 Else GoTo 680
a(68) = j68
a(14) = Pr9 - a(68): If b(a(14)) = 0 Then b(a(14)) = a(14): c(14) = a(14) Else GoTo 140
For j67 = m(4) To m(4) '' m1 To m2 'a(67)
If b(j67) = 0 Then b(j67) = j67: c(67) = j67 Else GoTo 670
a(67) = j67
a(15) = Pr9 - a(67): If b(a(15)) = 0 Then b(a(15)) = a(15): c(15) = a(15) Else GoTo 150
For j66 = m1 To m2 'a(66)
If b(j66) = 0 Then b(j66) = j66: c(66) = j66 Else GoTo 660
a(66) = j66
Cells(3, 1).Value = j66
a(16) = Pr9 - a(66): If b(a(16)) = 0 Then b(a(16)) = a(16): c(16) = a(16) Else GoTo 160
For j65 = m1 To m2 'a(65)
If b(j65) = 0 Then b(j65) = j65: c(65) = j65 Else GoTo 650
a(65) = j65
Cells(4, 1).Value = j65
a(64) = s1 - a(65) - a(66) - a(67) - a(68) - a(69) - a(70) - a(71) - a(72)
If a(64) < m1 Or a(64) > m2 Then GoTo 640
If b(a(64)) = 0 Then b(a(64)) = a(64): c(64) = a(64) Else GoTo 640
a(18) = Pr9 - a(64): If b(a(18)) = 0 Then b(a(18)) = a(18): c(18) = a(18) Else GoTo 180
a(17) = Pr9 - a(65): If b(a(17)) = 0 Then b(a(17)) = a(17): c(17) = a(17) Else GoTo 170
For j63 = m1 To m2 'a(63)
If b(j63) = 0 Then b(j63) = j63: c(63) = j63 Else GoTo 630
a(63) = j63
a(19) = Pr9 - a(63): If b(a(19)) = 0 Then b(a(19)) = a(19): c(19) = a(19) Else GoTo 10
For j62 = m1 To m2 'a(62)
If b(j62) = 0 Then b(j62) = j62: c(62) = j62 Else GoTo 620
a(62) = j62
a(61) = (-37*s1/9+6*a(74)+6*a(75)+6*a(76)-6*a(77)+10*a(78)+10*a(79)+10 * a(80) +2*a(81))/7
If a(61) <= 0 Or a(61) > 83 Or CInt(a(61)) <> a(61) Then GoTo 610
If b(a(61)) = 0 Then b(a(61)) = a(61): c(61) = a(61) Else GoTo 610
a(60) = (76*s1/9-14*a(62)-7*a(63)-11*a(74)-11*a(75)-11*a(76)+11*a(77)-9*a(78)-2*a(79)-9*a(80)+a(81))/14
If a(60) <= 0 Or a(60) > 83 Or CInt(a(60)) <> a(60) Then GoTo 600
If b(a(60)) = 0 Then b(a(60)) = a(60): c(60) = a(60) Else GoTo 600
a(22) = Pr9 - a(60): If b(a(22)) = 0 Then b(a(22)) = a(22): c(22) = a(22) Else GoTo 220
a(21) = Pr9 - a(61): If b(a(21)) = 0 Then b(a(21)) = a(21): c(21) = a(21) Else GoTo 210
a(20) = Pr9 - a(62): If b(a(20)) = 0 Then b(a(20)) = a(20): c(20) = a(20) Else GoTo 200
For j59 = m1 To m2 'a(59)
If b(j59) = 0 Then b(j59) = j59: c(59) = j59 Else GoTo 590
a(59) = j59
a(23) = Pr9 - a(59): If b(a(23)) = 0 Then b(a(23)) = a(23): c(23) = a(23) Else GoTo 230
For j58 = m1 To m2 'a(58)
If b(j58) = 0 Then b(j58) = j58: c(58) = j58 Else GoTo 580
a(58) = j58
a(57) = (-19*s1/9+8*a(74)+8*a(75)+8*a(76)-8*a(77)+4*a(78)+4*a(79)+4*a(80)-2*a(81))/7
If a(57) <= 0 Or a(57) > 83 Or CInt(a(57)) <> a(57) Then GoTo 570
If b(a(57)) = 0 Then b(a(57)) = a(57): c(57) = a(57) Else GoTo 570
a(56) = (8*s1/9-14*a(58)+14*a(59)+7*a(63)-3*a(74)+11*a(75)-3*a(76)+3*a(77)-5*a(78)+2*a(79)-5* a(80)- a(81))/14
If a(56) <= 0 Or a(56) > 83 Or CInt(a(56)) <> a(56) Then GoTo 560
If b(a(56)) = 0 Then b(a(56)) = a(56): c(56) = a(56) Else GoTo 560
a(55) =(77*s1/9-14*a(59)-7*a(63)-7*a(74)-14*a(75)-7*a(76)+7*a(77)-7*a(78)-14*a(79)-7*a(80))/7
If a(55) <= 0 Or a(55) > 83 Or CInt(a(55)) <> a(55) Then GoTo 550
If b(a(55)) = 0 Then b(a(55)) = a(55): c(55) = a(55) Else GoTo 550
a(54) = (-39*s1/9-7*a(63)-7*a(72)+12*a(74)+12*a(75)+12*a(76)-12*a(77)+13*a(78)+13*a(79)+13*a(80)-3*a(81))/7
If a(54) <= 0 Or a(54) > 83 Or CInt(a(54)) <> a(54) Then GoTo 540
If b(a(54)) = 0 Then b(a(54)) = a(54): c(54) = a(54) Else GoTo 540
a(28) = Pr9 - a(54): If b(a(28)) = 0 Then b(a(28)) = a(28): c(28) = a(28) Else GoTo 280
a(27) = Pr9 - a(55): If b(a(27)) = 0 Then b(a(27)) = a(27): c(27) = a(27) Else GoTo 270
a(26) = Pr9 - a(56): If b(a(26)) = 0 Then b(a(26)) = a(26): c(26) = a(26) Else GoTo 260
a(25) = Pr9 - a(57): If b(a(25)) = 0 Then b(a(25)) = a(25): c(25) = a(25) Else GoTo 250
a(24) = Pr9 - a(58): If b(a(24)) = 0 Then b(a(24)) = a(24): c(24) = a(24) Else GoTo 240
For j53 = m1 To m2 'a(53)
If b(j53) = 0 Then b(j53) = j53: c(53) = j53 Else GoTo 530
a(53) = j53
a(52) = (24*s1/9+7*a(63)-14*a(70)+5*a(74)+5*a(75)+5*a(76)-5*a(77)-a(78)-8*a(79)-a(80)-3* a(81))/14
If a(52) <= 0 Or a(52) > 83 Or CInt(a(52)) <> a(52) Then GoTo 520
If b(a(52)) = 0 Then b(a(52)) = a(52): c(52) = a(52) Else GoTo 520
a(51) = (50*s1/9-7*a(53)- 7*a(69)-7*a(71)-3*a(74)-3*a(75)-3*a(76)+3*a(77)-5*a(78)-5*a(79)-5*a(80)-a(81))/7
If a(51) <= 0 Or a(51) > 83 Then GoTo 510
If b(a(51)) = 0 Then b(a(51)) = a(51): c(51) = a(51) Else GoTo 510
a(50) = (-84 * s1 / 9 - 7 * a(59) - 7 * a(68) + 28 * a(73) + 49 * a(77) + 28 * a(81)) / 7
If a(50) <= 0 Or a(50) > 83 Then GoTo 500
If b(a(50)) = 0 Then b(a(50)) = a(50): c(50) = a(50) Else GoTo 500
a(32) = Pr9 - a(50): If b(a(32)) = 0 Then b(a(32)) = a(32): c(32) = a(32) Else GoTo 320
a(31) = Pr9 - a(51): If b(a(31)) = 0 Then b(a(31)) = a(31): c(31) = a(31) Else GoTo 310
a(30) = Pr9 - a(52): If b(a(30)) = 0 Then b(a(30)) = a(30): c(30) = a(30) Else GoTo 300
a(29) = Pr9 - a(53): If b(a(29)) = 0 Then b(a(29)) = a(29): c(29) = a(29) Else GoTo 290
''n9 = n9 + 1: GoSub 2650: End
For j49 = m1 To m2 'a(49)
If b(j49) = 0 Then b(j49) = j49: c(49) = j49 Else GoTo 490
a(49) = j49
a(48) = (74*s1/9-14*a(59)-7*a(63)-14*a(66)-5*a(74)-19*a(75)-5*a(76)+5*a(77)+a(78)-6*a(79)+a(80)+3 *a(81))/14
If a(48) <= 0 Or a(48) > 83 Or CInt(a(48)) <> a(48) Then GoTo 480
If b(a(48)) = 0 Then b(a(48)) = a(48): c(48) = a(48) Else GoTo 480
a(47) = (41*s1/9-7*a(49)-7*a(65)-7*a(67)-4*a(74)-4*a(75)-4*a(76)+4*a(77)-2*a(78)-2*a(79)-2*a(80)+a(81))/7
If a(47) <= 0 Or a(47) > 83 Then GoTo 470
If b(a(47)) = 0 Then b(a(47)) = a(47): c(47) = a(47) Else GoTo 470
a(46) = (-143*s1/9+14*a(59)+7*a(63)-7*a(64)+23*a(74)+30*a(75)+23*a(76)-16*a(77)+22*a(78)+29*a(79)+22 *a(80)+3*a(81))/7
If a(46) <= 0 Or a(46) > 83 Or CInt(a(46)) <> a(46) Then GoTo 460
If b(a(46)) = 0 Then b(a(46)) = a(46): c(46) = a(46) Else GoTo 460
a(45) = (43*s1/9-3*a(74)-3*a(75)-3*a(76)-4*a(77)-5*a(78)-5*a(79)-5*a(80)-8*a(81))/7
If a(45) <= 0 Or a(45) > 83 Or CInt(a(45)) <> a(45) Then GoTo 450
If b(a(45)) = 0 Then b(a(45)) = a(45): c(45) = a(45) Else GoTo 450
a(44) = (104*s1/9-14*a(49)-14*a(53)-14*a(58)+14*a(59)-14*a(62)+7*a(63)-14*a(67)-14*a(71)+3*a(74) +
+3*a(75)-11*a(76)+11*a(77)-9*a(78)-2*a(79)-23*a(80)+a(81))/14
If a(44) <=0 Or a(44) > 83 Then GoTo 440
If b(a(44)) = 0 Then b(a(44)) = a(44): c(44) = a(44) Else GoTo 440
a(43) = (50*s1/9-7*a(59)-7*a(63)-3*a(74)-3*a(75)-3*a(76)+3*a(77)-5*a(78)-12*a(79)-5*a(80)-a(81))/7
If a(43) <= 0 Or a(43) > 83 Or CInt(a(43)) <> a(43) Then GoTo 430
If b(a(43)) = 0 Then b(a(43)) = a(43): c(43) = a(43) Else GoTo 430
a(42) = (-162*s1/9+14*a(49)+14*a(53)+14*a(58)+14*a(62)+7*a(63)+14*a(67)+14*a(71)+17*a(74)+17*a(75) +
+31*a(76)-17*a(77)+5*a(78)+12*a(79)+19*a(80)+a(81))/14
If a(42) <= 0 Or a(42) > 83 Or CInt(a(42)) <> a(42) Then GoTo 420
If b(a(42)) = 0 Then b(a(42)) = a(42): c(42) = a(42) Else GoTo 420
a(40) = Pr9 - a(42): If b(a(40)) = 0 Then b(a(40)) = a(40): c(40) = a(40) Else GoTo 400
a(39) = Pr9 - a(43): If b(a(39)) = 0 Then b(a(39)) = a(39): c(39) = a(39) Else GoTo 390
a(38) = Pr9 - a(44): If b(a(38)) = 0 Then b(a(38)) = a(38): c(38) = a(38) Else GoTo 380
a(37) = Pr9 - a(45): If b(a(37)) = 0 Then b(a(37)) = a(37): c(37) = a(37) Else GoTo 370
a(36) = Pr9 - a(46): If b(a(36)) = 0 Then b(a(36)) = a(36): c(36) = a(36) Else GoTo 360
a(35) = Pr9 - a(47): If b(a(35)) = 0 Then b(a(35)) = a(35): c(35) = a(35) Else GoTo 350
a(34) = Pr9 - a(48): If b(a(34)) = 0 Then b(a(34)) = a(34): c(34) = a(34) Else GoTo 340
a(33) = Pr9 - a(49): If b(a(33)) = 0 Then b(a(33)) = a(33): c(33) = a(33) Else GoTo 330
n9 = n9 + 1: GoSub 2650: ''End
Erase b, c: GoTo 1000
b(c(33)) = 0: c(33) = 0
330 b(c(34)) = 0: c(34) = 0
340 b(c(35)) = 0: c(35) = 0
350 b(c(36)) = 0: c(36) = 0
360 b(c(37)) = 0: c(37) = 0
370 b(c(38)) = 0: c(38) = 0
380 b(c(39)) = 0: c(39) = 0
390 b(c(40)) = 0: c(40) = 0
400 b(c(42)) = 0: c(42) = 0
420 b(c(43)) = 0: c(43) = 0
430 b(c(44)) = 0: c(44) = 0
440 b(c(45)) = 0: c(45) = 0
450 b(c(46)) = 0: c(46) = 0
460 b(c(47)) = 0: c(47) = 0
470 b(c(48)) = 0: c(48) = 0
480 b(c(49)) = 0: c(49) = 0
490 Next j49
b(c(29)) = 0: c(29) = 0
290 b(c(30)) = 0: c(30) = 0
300 b(c(31)) = 0: c(31) = 0
310 b(c(32)) = 0: c(32) = 0
320 b(c(50)) = 0: c(50) = 0
500 b(c(51)) = 0: c(51) = 0
510 b(c(52)) = 0: c(52) = 0
520 b(c(53)) = 0: c(53) = 0
530 Next j53
b(c(24)) = 0: c(24) = 0
240 b(c(25)) = 0: c(25) = 0
250 b(c(26)) = 0: c(26) = 0
260 b(c(27)) = 0: c(27) = 0
270 b(c(28)) = 0: c(28) = 0
280 b(c(54)) = 0: c(54) = 0
540 b(c(55)) = 0: c(55) = 0
550 b(c(56)) = 0: c(56) = 0
560 b(c(57)) = 0: c(57) = 0
570 b(c(58)) = 0: c(58) = 0
580 Next j58
b(c(23)) = 0: c(23) = 0
230 b(c(59)) = 0: c(59) = 0
590 Next j59
b(c(20)) = 0: c(20) = 0
200 b(c(21)) = 0: c(21) = 0
210 b(c(22)) = 0: c(22) = 0
220 b(c(60)) = 0: c(60) = 0
600 b(c(61)) = 0: c(61) = 0
610 b(c(62)) = 0: c(62) = 0
620 Next j62
b(c(19)) = 0: c(19) = 0
10 b(c(63)) = 0: c(63) = 0
630 Next j63
b(c(17)) = 0: c(17) = 0
170 b(c(18)) = 0: c(18) = 0
180 b(c(64)) = 0: c(64) = 0
640 b(c(65)) = 0: c(65) = 0
650 Next j65
b(c(16)) = 0: c(16) = 0
160 b(c(66)) = 0: c(66) = 0
660 Next j66
b(c(15)) = 0: c(15) = 0
150 b(c(67)) = 0: c(67) = 0
670 Next j67
b(c(14)) = 0: c(14) = 0
140 b(c(68)) = 0: c(68) = 0
680 Next j68
b(c(13)) = 0: c(13) = 0
130 b(c(69)) = 0: c(69) = 0
690 Next j69
b(c(12)) = 0: c(12) = 0
120 b(c(70)) = 0: c(70) = 0
700 Next j70
b(c(11)) = 0: c(11) = 0
110 b(c(71)) = 0: c(71) = 0
710 Next j71
b(c(10)) = 0: c(10) = 0
100 b(c(72)) = 0: c(72) = 0
720 Next j72
1000 Next j100
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine MgcSqr98a")
End
' 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(1, 1).Value = n9
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
Cells(k1, k2 + 2).Value = j100
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
