' Calculates 4 x 4 Magic Squares of Squares
' Seiji Tomita (2018)
' Tested with Office 2007 under Windows 7
Sub SqrSqr4b()
Dim a(16), s(10)
y = MsgBox("Locked", vbCritical, "Routine SqrsSqrs4a")
End
n1 = 0: n9 = 0: n10 = 0: k1 = 1: k2 = 1
Sheets("Klad1").Select
For j11 = 1 To 10
k = j11: GoSub 100 'Select Subroutine: 100 ... 1100
GoSub 850: If fl1 = 0 Then GoTo 110 'Check Identical Numbers
GoSub 950: If fl1 = 0 Then GoTo 110 'Check Magic Properties (Back Check)
n9 = n9 + 1: GoSub 650 'Print
110 Next j11
End
' Solution #1
100 s1 = 50 * (k^2 + 337)
a(1) = (2 * k + 105)^2: a(2) = (3 * k + 38)^2: a(3) = (6 * k - 59)^2: a(4) = (k + 30)^2
a(5) = (k - 66)^2: a(6) = (6 * k + 5)^2: a(7) = (3 * k + 70)^2: a(8) = (2 * k - 87)^2
a(9) = (3 * k - 38)^2: a(10) = (2 * k - 105)^2: a(11) = (k - 30)^2: a(12) = (6 * k + 59)^2
a(13) = (6 * k - 5)^2: a(14) = (k + 66)^2: a(15) = (2 * k + 87)^2: a(16) = (3 * k - 70)^2
Return
' Solution #2
200 s1 = 130 * (k^2 + 281)
a(1) = (3 * k + 154)^2: a(2) = (6 * k + 13)^2: a(3) = (9 * k - 78)^2: a(4) = (2 * k + 81)^2
a(5) = (2 * k - 111)^2: a(6) = (9 * k + 18)^2: a(7) = (6 * k + 77)^2: a(8) = (3 * k - 134)^2
a(9) = (6 * k - 13)^2: a(10) = (3 * k - 154)^2: a(11) = (2 * k - 81)^2: a(12) = (9 * k + 78)^2
a(13) = (9 * k - 18)^2: a(14) = (2 * k + 111)^2: a(15) = (3 * k + 134)^2: a(16) = (6 * k - 77)^2
Return
' Solution #3
300 s1 = 125 * (k^2 + 373)
a(1) = (4 * k + 165)^2: a(2) = (6 * k + 2)^2: a(3) = (8 * k - 114)^2: a(4) = (3 * k + 80)^2
a(5) = (3 * k - 136)^2: a(6) = (8 * k + 30)^2: a(7) = (6 * k + 110)^2: a(8) = (4 * k - 123)^2
a(9) = (6 * k - 2)^2: a(10) = (4 * k - 165)^2: a(11) = (3 * k - 80)^2: a(12) = (8 * k + 114)^2
a(13) = (8 * k - 30)^2: a(14) = (3 * k + 136)^2: a(15) = (4 * k + 123)^2: a(16) = (6 * k - 110)^2
Return
' Solution #4
400 s1 = 130 * (2 * k^2 + 53)
a(1) = (3 * k + 70)^2: a(2) = (5 * k + 33)^2: a(3) = (15 * k - 26)^2: a(4) = (k + 15)^2
a(5) = (k - 30)^2: a(6) = (15 * k + 1)^2: a(7) = (5 * k + 42)^2: a(8) = (3 * k - 65)^2
a(9) = (5 * k - 33)^2: a(10) = (3 * k - 70)^2: a(11) = (k - 15)^2: a(12) = (15 * k + 26)^2
a(13) = (15 * k - 1)^2: a(14) = (k + 30)^2: a(15) = (3 * k + 65)^2: a(16) = (5 * k - 42)^2
Return
' Solution #5
500 s1 = 145 * (k^2 + 74)
a(1) = (4 * k + 80)^2: a(2) = (5 * k + 36)^2: a(3) = (10 * k - 53)^2: a(4) = (2 * k + 15)^2
a(5) = (2 * k - 55)^2: a(6) = (10 * k + 3)^2: a(7) = (5 * k + 64)^2: a(8) = (4 * k - 60)^2
a(9) = (5 * k - 36)^2: a(10) = (4 * k - 80)^2: a(11) = (2 * k - 15)^2: a(12) = (10 * k + 53)^2
a(13) = (10 * k - 3)^2: a(14) = (2 * k + 55)^2: a(15) = (4 * k + 60)^2: a(16) = (5 * k - 64)^2
Return
' Solution #6
600 s1 = 340 * (k^2 + 29)
a(1) = (5 * k + 81)^2: a(2) = (9 * k + 15)^2: a(3) = (15 * k - 43)^2: a(4) = (3 * k + 35)^2
a(5) = (3 * k - 55)^2: a(6) = (15 * k + 7)^2: a(7) = (9 * k + 45)^2: a(8) = (5 * k - 69)^2
a(9) = (9 * k - 15)^2: a(10) = (5 * k - 81)^2: a(11) = (3 * k - 35)^2: a(12) = (15 * k + 43)^2
a(13) = (15 * k - 7)^2: a(14) = (3 * k + 55)^2: a(15) = (5 * k + 69)^2: a(16) = (9 * k - 45)^2
Return
' Solution #7
700 s1 = 290 * (2 * k^2 + 37)
a(1) = (7 * k + 81)^2: a(2) = (9 * k + 42)^2: a(3) = (21 * k - 47)^2: a(4) = (3 * k + 14)^2
a(5) = (3 * k - 49)^2: a(6) = (21 * k + 2)^2: a(7) = (9 * k + 63)^2: a(8) = (7 * k - 66)^2
a(9) = (9 * k - 42)^2: a(10) = (7 * k - 81)^2: a(11) = (3 * k - 14)^2: a(12) = (21 * k + 47)^2
a(13) = (21 * k - 2)^2: a(14) = (3 * k + 49)^2: a(15) = (7 * k + 66)^2: a(16) = (9 * k - 63)^2
Return
' Solution #8
800 s1 = 130 * (k^2 + 281)
a(1) = (2 * k + 165)^2: a(2) = (5 * k + 34)^2: a(3) = (10 * k - 57)^2: a(4) = (k + 70)^2
a(5) = (k - 90)^2: a(6) = (10 * k + 7)^2: a(7) = (5 * k + 66)^2: a(8) = (2 * k - 155)^2
a(9) = (5 * k - 34)^2: a(10) = (2 * k - 165)^2: a(11) = (k - 70)^2: a(12) = (10 * k + 57)^2
a(13) = (10 * k - 7)^2: a(14) = (k + 90)^2: a(15) = (2 * k + 155)^2: a(16) = (5 * k - 66)^2
Return
' Solution #9
900 s1 = 221 * (k^2 + 85)
a(1) = (3 * k + 112)^2: a(2) = (8 * k + 6)^2: a(3) = (12 * k - 43)^2: a(4) = (2 * k + 66)^2
a(5) = (2 * k - 78)^2: a(6) = (12 * k + 11)^2: a(7) = (8 * k + 42)^2: a(8) = (3 * k - 104)^2
a(9) = (8 * k - 6)^2: a(10) = (3 * k - 112)^2: a(11) = (2 * k - 66)^2: a(12) = (12 * k + 43)^2
a(13) = (12 * k - 11)^2: a(14) = (2 * k + 78)^2: a(15) = (3 * k + 104)^2: a(16) = (8 * k - 42)^2
Return
' Solution #10
1000 s1 = 481 * (k^2 + 50)
a(1) = (3 * k + 128)^2: a(2) = (12 * k + 4)^2: a(3) = (18 * k - 33)^2: a(4) = (2 * k + 81)^2
a(5) = (2 * k - 87)^2: a(6) = (18 * k + 9)^2: a(7) = (12 * k + 32)^2: a(8) = (3 * k - 124)^2
a(9) = (12 * k - 4)^2: a(10) = (3 * k - 128)^2: a(11) = (2 * k - 81)^2: a(12) = (18 * k + 33)^2
a(13) = (18 * k - 9)^2: a(14) = (2 * k + 87)^2: a(15) = (3 * k + 124)^2: a(16) = (12 * k - 32)^2
Return
' Solution #11
1100 s1 = 325 * (k^2 + 149)
a(1) = (8 * k + 162)^2: a(2) = (9 * k + 24)^2: a(3) = (12 * k - 143)^2: a(4) = (6 * k + 34)^2
a(5) = (6 * k - 146)^2: a(6) = (12 * k + 17)^2: a(7) = (9 * k + 144)^2: a(8) = (8 * k - 78)^2
a(9) = (9 * k - 24)^2: a(10) = (8 * k - 162)^2: a(11) = (6 * k - 34)^2: a(12) = (12 * k + 143)^2
a(13) = (12 * k - 17)^2: a(14) = (6 * k + 146)^2: a(15) = (8 * k + 78)^2: a(16) = (9 * k - 144)^2
Return
' Print results (selected numbers)
640 For i1 = 1 To 16
Cells(n9, i1).Value = a(i1)
Next i1
Return
' Print results (squares)
650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 5: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 5
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(s1) + ", " + CStr(n9)
i3 = 0
For i1 = 1 To 4
For i2 = 1 To 4
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
' Exclude solutions with identical numbers
' Exclude a(i1) = 0
850 fl1 = 1
For j1 = 1 To 16
a2 = a(j1): If a2 = 0 Then fl1 = 0: Return
For j2 = (1 + j1) To 16
If a2 = a(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
' Check Magic Properties
950 fl1 = 1
s(1) = a(1) + a(2) + a(3) + a(4)
s(1) = a(1) + a(2) + a(3) + a(4)
s(2) = a(5) + a(6) + a(7) + a(8)
s(3) = a(9) + a(10) + a(11) + a(12)
s(4) = a(13) + a(14) + a(15) + a(16)
s(5) = a(1) + a(5) + a(9) + a(13)
s(6) = a(2) + a(6) + a(10) + a(14)
s(7) = a(3) + a(7) + a(11) + a(15)
s(8) = a(4) + a(8) + a(12) + a(16)
s(9) = a(1) + a(6) + a(11) + a(16)
s(10) = a(4) + a(7) + a(10) + a(13)
For j20 = 1 To 10
If s(j20) <> s1 Then fl1 = 0: Exit For
Next j20
Return
End Sub
