' Generates Bimagic Squares of order 8, Magic Sum 260, Victor Coccoz
' Tested with Office 2007 under Windows 7
Sub CnstrSqrs02()
Dim a(64), b(64), c(64), s(34)
y = MsgBox("Blocked", vbCritical, "CntrSqrs02")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
Sheets("Klad1").Select
For j1 = 47 To 94
GoSub 100 'Read a()
For j2 = 47 To 94
GoSub 200 'Read b()
For j3 = 1 To 64 'Calcualte c()
c(j3) = 8 * a(j3) + b(j3) + 1
Next j3
GoSub 300: If fl1 = 0 Then GoTo 20 'Check Identical Numbers
GoSub 400: If fl1 = 0 Then GoTo 20 'Check Magic Sum
GoSub 500: If fl1 = 0 Then GoTo 20 'Check Bimagic Sum
GoSub 600: If fl1 = 0 Then GoTo 20 'Check Trimagic Sum (Main Diagonals)
' n9 = n9 + 1: GoSub 1000 'Print first lines (Test)
n9 = n9 + 1: GoSub 2650 'Print results (Squares)
20 Next j2
10 Next j1
End
' Read a()
100
a(1) = Sheets("Algebraisch8").Cells(j1, 15).Value 'D
a(2) = Sheets("Algebraisch8").Cells(j1, 14).Value 'd
a(3) = Sheets("Algebraisch8").Cells(j1, 13).Value 'c
a(4) = Sheets("Algebraisch8").Cells(j1, 17).Value 'B
a(5) = Sheets("Algebraisch8").Cells(j1, 16).Value 'C
a(6) = Sheets("Algebraisch8").Cells(j1, 12).Value 'b
a(7) = Sheets("Algebraisch8").Cells(j1, 11).Value 'a
a(8) = Sheets("Algebraisch8").Cells(j1, 18).Value 'A
a(9) = a(3):a(10) = a(5):a(11) = a(1):a(12) = a(7):a(13) = a(2):a(14) = a(8):a(15) = a(4):a(16) = a(6):
a(17) = a(6):a(18) = a(4):a(19) = a(8):a(20) = a(2):a(21) = a(7):a(22) = a(1):a(23) = a(5):a(24) = a(3):
a(25) = a(2):a(26) = a(1):a(27) = a(5):a(28) = a(6):a(29) = a(3):a(30) = a(4):a(31) = a(8):a(32) = a(7):
a(33) = a(8):a(34) = a(7):a(35) = a(6):a(36) = a(5):a(37) = a(4):a(38) = a(3):a(39) = a(2):a(40) = a(1):
a(41) = a(5):a(42) = a(3):a(43) = a(2):a(44) = a(8):a(45) = a(1):a(46) = a(7):a(47) = a(6):a(48) = a(4):
a(49) = a(4):a(50) = a(6):a(51) = a(7):a(52) = a(1):a(53) = a(8):a(54) = a(2):a(55) = a(3):a(56) = a(5):
a(57) = a(7):a(58) = a(8):a(59) = a(4):a(60) = a(3):a(61) = a(6):a(62) = a(5):a(63) = a(1):a(64) = a(2):
Return
' Read b()
200
b(1) = Sheets("Algebraisch8").Cells(j2, 16).Value 'R
b(2) = Sheets("Algebraisch8").Cells(j2, 12).Value 'q
b(3) = Sheets("Algebraisch8").Cells(j2, 17).Value 'Q
b(4) = Sheets("Algebraisch8").Cells(j2, 14).Value 's
b(5) = Sheets("Algebraisch8").Cells(j2, 13).Value 'r
b(6) = Sheets("Algebraisch8").Cells(j2, 18).Value 'P
b(7) = Sheets("Algebraisch8").Cells(j2, 11).Value 'p
b(8) = Sheets("Algebraisch8").Cells(j2, 15).Value 'S
b(9) = b(8):b(10) = b(7):b(11) = b(6):b(12) = b(5):b(13) = b(4):b(14) = b(3):b(15) = b(2):b(16) = b(1):
b(17) = b(7):b(18) = b(8):b(19) = b(4):b(20) = b(3):b(21) = b(6):b(22) = b(5):b(23) = b(1):b(24) = b(2):
b(25) = b(6):b(26) = b(4):b(27) = b(8):b(28) = b(2):b(29) = b(7):b(30) = b(1):b(31) = b(5):b(32) = b(3):
b(33) = b(2):b(34) = b(1):b(35) = b(5):b(36) = b(6):b(37) = b(3):b(38) = b(4):b(39) = b(8):b(40) = b(7):
b(41) = b(3):b(42) = b(5):b(43) = b(1):b(44) = b(7):b(45) = b(2):b(46) = b(8):b(47) = b(4):b(48) = b(6):
b(49) = b(5):b(50) = b(3):b(51) = b(2):b(52) = b(8):b(53) = b(1):b(54) = b(7):b(55) = b(6):b(56) = b(4):
b(57) = b(4):b(58) = b(6):b(59) = b(7):b(60) = b(1):b(61) = b(8):b(62) = b(2):b(63) = b(3):b(64) = b(5):
Return
' Check Identical Numbers
300 fl1 = 1
For j10 = 1 To 64
c2 = c(j10)
For j20 = (1 + j10) To 64
If c2 = c(j20) Then fl1 = 0: Return
Next j20
Next j10
Return
' Check Magic Sum
400 fl1 = 1
' Rows
s(1) = c(1) + c(2) + c(3) + c(4) + c(5) + c(6) + c(7) + c(8)
s(2) = c(9) + c(10) + c(11) + c(12) + c(13) + c(14) + c(15) + c(16)
s(3) = c(17) + c(18) + c(19) + c(20) + c(21) + c(22) + c(23) + c(24)
s(4) = c(25) + c(26) + c(27) + c(28) + c(29) + c(30) + c(31) + c(32)
s(5) = c(33) + c(34) + c(35) + c(36) + c(37) + c(38) + c(39) + c(40)
s(6) = c(41) + c(42) + c(43) + c(44) + c(45) + c(46) + c(47) + c(48)
s(7) = c(49) + c(50) + c(51) + c(52) + c(53) + c(54) + c(55) + c(56)
s(8) = c(57) + c(58) + c(59) + c(60) + c(61) + c(62) + c(63) + c(64)
' Columns
s(9) = c(1) + c(9) + c(17) + c(25) + c(33) + c(41) + c(49) + c(57)
s(10) = c(2) + c(10) + c(18) + c(26) + c(34) + c(42) + c(50) + c(58)
s(11) = c(3) + c(11) + c(19) + c(27) + c(35) + c(43) + c(51) + c(59)
s(12) = c(4) + c(12) + c(20) + c(28) + c(36) + c(44) + c(52) + c(60)
s(13) = c(5) + c(13) + c(21) + c(29) + c(37) + c(45) + c(53) + c(61)
s(14) = c(6) + c(14) + c(22) + c(30) + c(38) + c(46) + c(54) + c(62)
s(15) = c(7) + c(15) + c(23) + c(31) + c(39) + c(47) + c(55) + c(63)
s(16) = c(8) + c(16) + c(24) + c(32) + c(40) + c(48) + c(56) + c(64)
' Diagonals
s(17) = c(1) + c(10) + c(19) + c(28) + c(37) + c(46) + c(55) + c(64) 'Main
s(18) = c(8) + c(15) + c(22) + c(29) + c(36) + c(43) + c(50) + c(57) 'Main
s(19) = c(5) + c(14) + c(23) + c(32) + c(33) + c(42) + c(51) + c(60) 'Semi
s(20) = c(4) + c(11) + c(18) + c(25) + c(40) + c(47) + c(54) + c(61) 'Semi
For i1 = 1 To 18
If s(i1) <> 260 Then fl1 = 0: Return
Next i1
Return
' Check Bimagic Sum
500 fl1 = 1
' Rows
s(1) = c(1) ^ 2 + c(2) ^ 2 + c(3) ^ 2 + c(4) ^ 2 + c(5) ^ 2 + c(6) ^ 2 + c(7) ^ 2 + c(8) ^ 2
s(2) = c(9) ^ 2 + c(10) ^ 2 + c(11) ^ 2 + c(12) ^ 2 + c(13) ^ 2 + c(14) ^ 2 + c(15) ^ 2 + c(16) ^ 2
s(3) = c(17) ^ 2 + c(18) ^ 2 + c(19) ^ 2 + c(20) ^ 2 + c(21) ^ 2 + c(22) ^ 2 + c(23) ^ 2 + c(24) ^ 2
s(4) = c(25) ^ 2 + c(26) ^ 2 + c(27) ^ 2 + c(28) ^ 2 + c(29) ^ 2 + c(30) ^ 2 + c(31) ^ 2 + c(32) ^ 2
s(5) = c(33) ^ 2 + c(34) ^ 2 + c(35) ^ 2 + c(36) ^ 2 + c(37) ^ 2 + c(38) ^ 2 + c(39) ^ 2 + c(40) ^ 2
s(6) = c(41) ^ 2 + c(42) ^ 2 + c(43) ^ 2 + c(44) ^ 2 + c(45) ^ 2 + c(46) ^ 2 + c(47) ^ 2 + c(48) ^ 2
s(7) = c(49) ^ 2 + c(50) ^ 2 + c(51) ^ 2 + c(52) ^ 2 + c(53) ^ 2 + c(54) ^ 2 + c(55) ^ 2 + c(56) ^ 2
s(8) = c(57) ^ 2 + c(58) ^ 2 + c(59) ^ 2 + c(60) ^ 2 + c(61) ^ 2 + c(62) ^ 2 + c(63) ^ 2 + c(64) ^ 2
' Columns
s(9) = c(1) ^ 2 + c(9) ^ 2 + c(17) ^ 2 + c(25) ^ 2 + c(33) ^ 2 + c(41) ^ 2 + c(49) ^ 2 + c(57) ^ 2
s(10) = c(2) ^ 2 + c(10) ^ 2 + c(18) ^ 2 + c(26) ^ 2 + c(34) ^ 2 + c(42) ^ 2 + c(50) ^ 2 + c(58) ^ 2
s(11) = c(3) ^ 2 + c(11) ^ 2 + c(19) ^ 2 + c(27) ^ 2 + c(35) ^ 2 + c(43) ^ 2 + c(51) ^ 2 + c(59) ^ 2
s(12) = c(4) ^ 2 + c(12) ^ 2 + c(20) ^ 2 + c(28) ^ 2 + c(36) ^ 2 + c(44) ^ 2 + c(52) ^ 2 + c(60) ^ 2
s(13) = c(5) ^ 2 + c(13) ^ 2 + c(21) ^ 2 + c(29) ^ 2 + c(37) ^ 2 + c(45) ^ 2 + c(53) ^ 2 + c(61) ^ 2
s(14) = c(6) ^ 2 + c(14) ^ 2 + c(22) ^ 2 + c(30) ^ 2 + c(38) ^ 2 + c(46) ^ 2 + c(54) ^ 2 + c(62) ^ 2
s(15) = c(7) ^ 2 + c(15) ^ 2 + c(23) ^ 2 + c(31) ^ 2 + c(39) ^ 2 + c(47) ^ 2 + c(55) ^ 2 + c(63) ^ 2
s(16) = c(8) ^ 2 + c(16) ^ 2 + c(24) ^ 2 + c(32) ^ 2 + c(40) ^ 2 + c(48) ^ 2 + c(56) ^ 2 + c(64) ^ 2
' Diagonals
s(17) = c(1) ^ 2 + c(10) ^ 2 + c(19) ^ 2 + c(28) ^ 2 + c(37) ^ 2 + c(46) ^ 2 + c(55) ^ 2 + c(64) ^ 2 'Main
s(18) = c(8) ^ 2 + c(15) ^ 2 + c(22) ^ 2 + c(29) ^ 2 + c(36) ^ 2 + c(43) ^ 2 + c(50) ^ 2 + c(57) ^ 2 'Main
s(19) = c(5) ^ 2 + c(14) ^ 2 + c(23) ^ 2 + c(32) ^ 2 + c(33) ^ 2 + c(42) ^ 2 + c(51) ^ 2 + c(60) ^ 2 'Semi
s(20) = c(4) ^ 2 + c(11) ^ 2 + c(18) ^ 2 + c(25) ^ 2 + c(40) ^ 2 + c(47) ^ 2 + c(54) ^ 2 + c(61) ^ 2 'Semi
For i1 = 1 To 18
If s(i1) <> 11180 Then fl1 = 0: Return
Next i1
Return
' Check Trimagic Sum (Main Diagonals)
600 fl1 = 1
s(1) = c(1) ^ 3 + c(10) ^ 3 + c(19) ^ 3 + c(28) ^ 3 + c(37) ^ 3 + c(46) ^ 3 + c(55) ^ 3 + c(64) ^ 3 'Main
s(2) = c(8) ^ 3 + c(15) ^ 3 + c(22) ^ 3 + c(29) ^ 3 + c(36) ^ 3 + c(43) ^ 3 + c(50) ^ 3 + c(57) ^ 3 'Main
s(3) = c(5) ^ 3 + c(14) ^ 3 + c(23) ^ 3 + c(32) ^ 3 + c(33) ^ 3 + c(42) ^ 3 + c(51) ^ 3 + c(60) ^ 3 'Semi
s(4) = c(4) ^ 3 + c(11) ^ 3 + c(18) ^ 3 + c(25) ^ 3 + c(40) ^ 3 + c(47) ^ 3 + c(54) ^ 3 + c(61) ^ 3 'Semi
For i1 = 1 To 2
If s(i1) <> 540800 Then fl1 = 0: Return
Next i1
Return
' Print Squares
700
Return
' Print Lines
1000 Cells(n9, 28).Select
For i1 = 1 To 8
Cells(n9, i1).Value = a(i1)
Cells(n9, i1 + 9).Value = b(i1)
Cells(n9, i1 + 18).Value = c(i1)
Next i1
Cells(n9, 27).Value = j1
Cells(n9, 28).Value = j2
Return
' Print results (squares)
2650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 9: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 9
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 8
For i2 = 1 To 8
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = c(i3)
Next i2
Next i1
Return
End Sub
