' Constructs Euler Squares of order 5
' Tested with Office 2007 under Windows 7
Sub CnstrSqrs5b()
Dim a2(5), b2(5), a(25), b(25), c(25)
y = MsgBox("Locked", vbExclamation, "Routine CnstrSqrs5b")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
Sheets("Klad1").Select
t1 = Timer
For j1 = 2 To 25
' Read (Balanced) Magic Lines
For j2 = 1 To 5: a2(j2) = Sheets("Att53a").Cells(j1, j2).Value: Next j2
For j2 = 1 To 5: b2(j2) = Sheets("Att53a").Cells(j1, j2 + 6).Value: Next j2
s1 = Sheets("Att53a").Cells(j1, 15).Value
' Construct squares a() and b()
GoSub 200
' Calculate Square c()
For j2 = 1 To 25
c(j2) = a(j2) + b(j2)
Next j2
' Print results
GoSub 800: If fl1 = 0 Then GoTo 70
' n9 = n9 + 1: GoSub 640 'Lines
n9 = n9 + 1: GoSub 650 'Squares
70 Next j1
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, vbInformation, "Routine CnstrSqrs5b")
End
' Construct squares a() and b()
200
' Pan Magic
'' a(1) = a2(1): a(2) = a2(2): a(3) = a2(3): a(4) = a2(4): a(5) = a2(5):
'' a(6) = a2(3): a(7) = a2(4): a(8) = a2(5): a(9) = a2(1): a(10) = a2(2):
'' a(11) = a2(5): a(12) = a2(1): a(13) = a2(2): a(14) = a2(3): a(15) = a2(4):
'' a(16) = a2(2): a(17) = a2(3): a(18) = a2(4): a(19) = a2(5): a(20) = a2(1):
'' a(21) = a2(4): a(22) = a2(5): a(23) = a2(1): a(24) = a2(2): a(25) = a2(3):
'' b(1) = b2(1): b(2) = b2(2): b(3) = b2(3): b(4) = b2(4): b(5) = b2(5):
'' b(6) = b2(4): b(7) = b2(5): b(8) = b2(1): b(9) = b2(2): b(10) = b2(3):
'' b(11) = b2(2): b(12) = b2(3): b(13) = b2(4): b(14) = b2(5): b(15) = b2(1):
'' b(16) = b2(5): b(17) = b2(1): b(18) = b2(2): b(19) = b2(3): b(20) = b2(4):
'' b(21) = b2(3): b(22) = b2(4): b(23) = b2(5): b(24) = b2(1): b(25) = b2(2):
' Ultra Magic
'' a(1) = a2(5): a(2) = a2(1): a(3) = a2(4): a(4) = a2(3): a(5) = a2(2):
'' a(6) = a2(3): a(7) = a2(2): a(8) = a2(5): a(9) = a2(1): a(10) = a2(4):
'' a(11) = a2(1): a(12) = a2(4): a(13) = a2(3): a(14) = a2(2): a(15) = a2(5):
'' a(16) = a2(2): a(17) = a2(5): a(18) = a2(1): a(19) = a2(4): a(20) = a2(3):
'' a(21) = a2(4): a(22) = a2(3): a(23) = a2(2): a(24) = a2(5): a(25) = a2(1):
'' b(1) = b2(5): b(2) = b2(3): b(3) = b2(1): b(4) = b2(4): b(5) = b2(2):
'' b(6) = b2(1): b(7) = b2(4): b(8) = b2(2): b(9) = b2(5): b(10) = b2(3):
'' b(11) = b2(2): b(12) = b2(5): b(13) = b2(3): b(14) = b2(1): b(15) = b2(4):
'' b(16) = b2(3): b(17) = b2(1): b(18) = b2(4): b(19) = b2(2): b(20) = b2(5):
'' b(21) = b2(4): b(22) = b2(2): b(23) = b2(5): b(24) = b2(3): b(25) = b2(1):
' Associated (Based on Semi Latin)
'' a(1) = a2(5): a(2) = a2(4): a(3) = a2(2): a(4) = a2(3): a(5) = a2(1):
'' a(6) = a2(3): a(7) = a2(2): a(8) = a2(1): a(9) = a2(4): a(10) = a2(5):
'' a(11) = a2(1): a(12) = a2(4): a(13) = a2(3): a(14) = a2(2): a(15) = a2(5):
'' a(16) = a2(1): a(17) = a2(2): a(18) = a2(5): a(19) = a2(4): a(20) = a2(3):
'' a(21) = a2(5): a(22) = a2(3): a(23) = a2(4): a(24) = a2(2): a(25) = a2(1):
'' b(1) = b2(5): b(2) = b2(3): b(3) = b2(1): b(4) = b2(1): b(5) = b2(5):
'' b(6) = b2(4): b(7) = b2(2): b(8) = b2(4): b(9) = b2(2): b(10) = b2(3):
'' b(11) = b2(2): b(12) = b2(1): b(13) = b2(3): b(14) = b2(5): b(15) = b2(4):
'' b(16) = b2(3): b(17) = b2(4): b(18) = b2(2): b(19) = b2(4): b(20) = b2(2):
'' b(21) = b2(1): b(22) = b2(5): b(23) = b2(5): b(24) = b2(3): b(25) = b2(1):
' Concentric (Based on Semi Latin)
a(1) = a2(1): a(2) = a2(4): a(3) = a2(5): a(4) = a2(2): a(5) = a2(3):
a(6) = a2(5): a(7) = a2(2): a(8) = a2(4): a(9) = a2(3): a(10) = a2(1):
a(11) = a2(1): a(12) = a2(4): a(13) = a2(3): a(14) = a2(2): a(15) = a2(5):
a(16) = a2(5): a(17) = a2(3): a(18) = a2(2): a(19) = a2(4): a(20) = a2(1):
a(21) = a2(3): a(22) = a2(2): a(23) = a2(1): a(24) = a2(4): a(25) = a2(5):
b(1) = b2(3): b(2) = b2(5): b(3) = b2(1): b(4) = b2(5): b(5) = b2(1):
b(6) = b2(2): b(7) = b2(3): b(8) = b2(4): b(9) = b2(2): b(10) = b2(4):
b(11) = b2(1): b(12) = b2(2): b(13) = b2(3): b(14) = b2(4): b(15) = b2(5):
b(16) = b2(4): b(17) = b2(4): b(18) = b2(2): b(19) = b2(3): b(20) = b2(2):
b(21) = b2(5): b(22) = b2(1): b(23) = b2(5): b(24) = b2(1): b(25) = b2(3):
Return
' Exclude solutions with identical numbers
800 fl1 = 1
For j10 = 1 To 25
c2 = c(j10)
For j20 = (1 + j10) To 25
If c2 = c(j20) Then fl1 = 0: Return
Next j20
Next j10
Return
' Print results (selected numbers)
640 Cells(n9, 26).Select
For i1 = 1 To 25
Cells(n9, i1).Value = c(i1)
Next i1
Cells(n9, 26).Value = n9
Return
' Print results (squares)
650 n1 = n1 + 1
If n1 = 5 Then
n1 = 1: k1 = k1 + 6: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 6
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = s1
i3 = 0
For i1 = 1 To 5
For i2 = 1 To 5
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = c(i3)
Next i2
Next i1
Return
End Sub
