' Generates Bimagic Squares of order 8, Magic Sum 260, André Gérardin
' Based on Sudoku Comparable Lines
' Tested with Office 2007 under Windows 7
Sub CnstrSqrs06()
Dim a(64), b(64), c(64), s(34)
y = MsgBox("Blocked", vbCritical, "CnstrSqrs06")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
Sheets("Klad1").Select
For j1 = 2 To 49
GoSub 100 'Read a()
For j2 = 2 To 49
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 and Semi 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() A L T K I R C H
100 For j3 = 1 To 8
a(j3) = Sheets("RangeA").Cells(j1, j3).Value
Next j3
a(9) = a(3):a(10) = a(4):a(11) = a(1):a(12) = a(2):a(13) = a(7):a(14) = a(8):a(15) = a(5):a(16) = a(6):
a(17) = a(8):a(18) = a(7):a(19) = a(6):a(20) = a(5):a(21) = a(4):a(22) = a(3):a(23) = a(2):a(24) = a(1):
a(25) = a(6):a(26) = a(5):a(27) = a(8):a(28) = a(7):a(29) = a(2):a(30) = a(1):a(31) = a(4):a(32) = a(3):
a(33) = a(7):a(34) = a(8):a(35) = a(5):a(36) = a(6):a(37) = a(3):a(38) = a(4):a(39) = a(1):a(40) = a(2):
a(41) = a(5):a(42) = a(6):a(43) = a(7):a(44) = a(8):a(45) = a(1):a(46) = a(2):a(47) = a(3):a(48) = a(4):
a(49) = a(2):a(50) = a(1):a(51) = a(4):a(52) = a(3):a(53) = a(6):a(54) = a(5):a(55) = a(8):a(56) = a(7):
a(57) = a(4):a(58) = a(3):a(59) = a(2):a(60) = a(1):a(61) = a(8):a(62) = a(7):a(63) = a(6):a(64) = a(5):
Return
' Read b() e s p a l i o n
200 For j3 = 1 To 8
b(j3) = Sheets("RangeB").Cells(j2, j3).Value
Next j3
b(9) = b(4):b(10) = b(3):b(11) = b(2):b(12) = b(1):b(13) = b(8):b(14) = b(7):b(15) = b(6):b(16) = b(5):
b(17) = b(5):b(18) = b(6):b(19) = b(7):b(20) = b(8):b(21) = b(1):b(22) = b(2):b(23) = b(3):b(24) = b(4):
b(25) = b(8):b(26) = b(7):b(27) = b(6):b(28) = b(5):b(29) = b(4):b(30) = b(3):b(31) = b(2):b(32) = b(1):
b(33) = b(2):b(34) = b(1):b(35) = b(4):b(36) = b(3):b(37) = b(6):b(38) = b(5):b(39) = b(8):b(40) = b(7):
b(41) = b(3):b(42) = b(4):b(43) = b(1):b(44) = b(2):b(45) = b(7):b(46) = b(8):b(47) = b(5):b(48) = b(6):
b(49) = b(6):b(50) = b(5):b(51) = b(8):b(52) = b(7):b(53) = b(2):b(54) = b(1):b(55) = b(4):b(56) = b(3):
b(57) = b(7):b(58) = b(8):b(59) = b(5):b(60) = b(6):b(61) = b(3):b(62) = b(4):b(63) = b(1):b(64) = b(2):
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)
' Pan Diagonals
s(17) = c(1) + c(10) + c(19) + c(28) + c(37) + c(46) + c(55) + c(64) 'Main
s(18) = c(2) + c(11) + c(20) + c(29) + c(38) + c(47) + c(56) + c(57)
s(19) = c(3) + c(12) + c(21) + c(30) + c(39) + c(48) + c(49) + c(58)
s(20) = c(4) + c(13) + c(22) + c(31) + c(40) + c(41) + c(50) + c(59)
s(21) = c(5) + c(14) + c(23) + c(32) + c(33) + c(42) + c(51) + c(60) 'Semi
s(22) = c(6) + c(15) + c(24) + c(25) + c(34) + c(43) + c(52) + c(61)
s(23) = c(7) + c(16) + c(17) + c(26) + c(35) + c(44) + c(53) + c(62)
s(24) = c(8) + c(9) + c(18) + c(27) + c(36) + c(45) + c(54) + c(63)
s(25) = c(8) + c(15) + c(22) + c(29) + c(36) + c(43) + c(50) + c(57) 'Main
s(26) = c(1) + c(16) + c(23) + c(30) + c(37) + c(44) + c(51) + c(58)
s(27) = c(2) + c(9) + c(24) + c(31) + c(38) + c(45) + c(52) + c(59)
s(28) = c(3) + c(10) + c(17) + c(32) + c(39) + c(46) + c(53) + c(60)
s(29) = c(4) + c(11) + c(18) + c(25) + c(40) + c(47) + c(54) + c(61) 'Semi
s(30) = c(5) + c(12) + c(19) + c(26) + c(33) + c(48) + c(55) + c(62)
s(31) = c(6) + c(13) + c(20) + c(27) + c(34) + c(41) + c(56) + c(63)
s(32) = c(7) + c(14) + c(21) + c(28) + c(35) + c(42) + c(49) + c(64)
For i1 = 1 To 32
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
' Pan 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(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(19) = 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(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 20
If s(i1) <> 11180 Then fl1 = 0: Return
Next i1
Return
' Check Trimagic Sum (Main and Semi 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(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(3) = 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(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 4
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
