' Searches for 4 x 4 Magic Squares of Squares

' Tested with Office 2007 under Windows 7

```Sub SqrSqr4a()

Dim a(16)

y = MsgBox("Locked", vbCritical, "Routine SqrsSqrs4a")
End

n1 = 0: n9 = 0: n10 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 87
m3 = m1 ^ 2: m4 = m2 ^ 2

sMin = 2823
sMax = 9775

t1 = Timer

For j100 = sMin To sMax         'Magic sum

n10 = 0: s1 = j100
Cells(k1 + 1, 1).Value = j100

For j16 = m1 To m2                                          'a(16) = 9
Cells(k1 + 2, 1).Value = j16
a(16) = j16 ^ 2

For j15 = m1 To m2                                          'a(15) = 44
Cells(k1 + 3, 1).Value = j15
a(15) = j15 ^ 2
i10 = 15: GoSub 850: If fl1 = 0 Then GoTo 150

For j14 = m1 To m2                                          'a(14) = 27
a(14) = j14 ^ 2
i10 = 14: GoSub 850: If fl1 = 0 Then GoTo 140

a(13) = s1 - a(14) - a(15) - a(16)
If a(13) < m3 Or a(13) > m4 Then GoTo 140
i10 = 13: GoSub 850: If fl1 = 0 Then GoTo 140
a2 = Sqr(a(13)): If Int(a2) <> a2 Then GoTo 140

For j12 = m1 To m2                                          'a(12) = 42
a(12) = j12 ^ 2
i10 = 12: GoSub 850: If fl1 = 0 Then GoTo 120

For j11 = m1 To m2                                          'a(11) = 13
a(11) = j11 ^ 2
i10 = 11: GoSub 850: If fl1 = 0 Then GoTo 110

For j10 = m1 To m2                                          'a(10) = 36
a(10) = j10 ^ 2
i10 = 10: GoSub 850: If fl1 = 0 Then GoTo 100

a(9) = s1 - a(10) - a(11) - a(12)
If a(9) < m3 Or a(9) > m4 Then GoTo 100
i10 = 9: GoSub 850: If fl1 = 0 Then GoTo 100
a2 = Sqr(a(9)): If Int(a2) <> a2 Then GoTo 100

For j8 = m1 To m2                                           'a(8) = 32
a(8) = j8 ^ 2

a(7) = a(8) - a(10) + a(12) - a(13) + a(16)
If a(7) < m3 Or a(7) > m4 Then GoTo 80
a2 = Sqr(a(7)): If Int(a2) <> a2 Then GoTo 80
a(6) = s1 - a(8) - a(11) - a(12) + a(13) - a(16)
If a(6) < m3 Or a(6) > m4 Then GoTo 80
a2 = Sqr(a(6)): If Int(a2) <> a2 Then GoTo 80
a(5) = -a(8) + a(10) + a(11)
If a(5) < m3 Or a(5) > m4 Then GoTo 80
a2 = Sqr(a(5)): If Int(a2) <> a2 Then GoTo 80
a(4) = s1 - a(7) - a(10) - a(13)
If a(4) < m3 Or a(4) > m4 Then GoTo 80
a2 = Sqr(a(4)): If Int(a2) <> a2 Then GoTo 80
a(3) = -s1 - a(8) + a(9) + 2 * a(10) + 2 * a(13) + a(14)
If a(3) < m3 Or a(3) > m4 Then GoTo 80
a2 = Sqr(a(3)): If Int(a2) <> a2 Then GoTo 80
a(2) = a(8) - a(9) - 2 * a(10) + a(15) + 2 * a(16)
If a(2) < m3 Or a(2) > m4 Then GoTo 80
a2 = Sqr(a(2)): If Int(a2) <> a2 Then GoTo 80
a(1) = a(8) + a(12) - a(13)
If a(1) < m3 Or a(1) > m4 Then GoTo 80
a2 = Sqr(a(1)): If Int(a2) <> a2 Then GoTo 80

'                           Exclude solutions with identical numbers

GoSub 800: If fl1 = 0 Then GoTo 80

'                           n9 = n9 + 1: GoSub 640 'Print results (selected numbers)
n10 = n10 + 1
n9 = n9 + 1: GoSub 650 'Print results (squares)
GoTo 1000              'Print only first square

80 Next j8

100 Next j10
110 Next j11
120 Next j12

140 Next j14
150 Next j15
160 Next j16

n10 = 0

1000 Next j100

t2 = Timer

t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
y = MsgBox(t10, 0, "Routine SqrsSqrs4a")

End

'   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
If n10 = 1 Then
Cells(k1, k2 + 1).Value = CStr(n10) + " (MC = " + CStr(s1) + " )"
Else
Cells(k1, k2 + 1).Value = CStr(n10)
End If

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

800 fl1 = 1
For j1 = 1 To 16
a2 = a(j1)
For j2 = (1 + j1) To 16
If a2 = a(j2) Then fl1 = 0: Return
Next j2
Next j1
Return

'   Exclude solutions with identical numbers (intermediate check)

850 fl1 = 1
j1 = i10
a2 = a(j1)
For j2 = (1 + j1) To 16
If a2 = a(j2) Then fl1 = 0: Return
Next j2
Return

End Sub
```