' Generates Bimagic Squares of order 9 based on Sudoku Squares (Keedwell)
' Tested with Office 365 under Windows 10
Sub CnstrSqrs9c()
Dim b1(81), b2(81), b(9), a(81), c(81), s9(29)
Dim a1(81)
Sheets("Klad1").Select
y = MsgBox("Locked", vbCritical, "Routine CnstrSqrs9c")
End
n4 = 1152
n2 = 0: n9 = 0: k1 = 1: k2 = 1
s1 = 369
t1 = Timer
For j1 = 1 To n4
b(1) = Sheets("B1").Cells(j1, 1).Value: b(2) = Sheets("B1").Cells(j1, 2).Value:
b(3) = Sheets("B1").Cells(j1, 3).Value:
b(4) = Sheets("B1").Cells(j1, 10).Value: b(5) = Sheets("B1").Cells(j1, 11).Value:
b(6) = Sheets("B1").Cells(j1, 12).Value:
b(7) = Sheets("B1").Cells(j1, 19).Value: b(8) = Sheets("B1").Cells(j1, 20).Value:
b(9) = Sheets("B1").Cells(j1, 21).Value:
j30 = 5: GoSub 900
For j2 = j1 To j1
b(1) = Sheets("B2").Cells(j2, 1).Value: b(2) = Sheets("B2").Cells(j2, 2).Value:
b(3) = Sheets("B2").Cells(j2, 3).Value:
b(4) = Sheets("B2").Cells(j2, 10).Value: b(5) = Sheets("B2").Cells(j2, 11).Value:
b(6) = Sheets("B2").Cells(j2, 12).Value:
b(7) = Sheets("B2").Cells(j2, 19).Value: b(8) = Sheets("B2").Cells(j2, 20).Value:
b(9) = Sheets("B2").Cells(j2, 21).Value:
j30 = 6: GoSub 900
For j4 = 1 To 81
a(j4) = 9 * b1(j4) + b2(j4) + 1
Next j4
GoSub 300: If fl1 = 0 Then GoTo 20 'Check identical numbers
GoSub 400 'Construct Square c() (Squared Elements)
GoSub 500: If fl1 = 0 Then GoTo 20 'Check Magic Sum c()
GoSub 800: If fl1 = 0 Then GoTo 20 'Check with Original Tarry Cazalas Square
' n9 = n9 + 1: GoSub 740 'Print results (selected numbers)
n9 = n9 + 1: GoSub 750 'Print results (squares)
' n9 = n9 + 1: Cells(1, 1).Value = n9 'Counting
20 Next j2
Next j1
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CnstrSqrs9c")
End
' Check with Original Tarry Cazalas Square
800 fl1 = 1
For i1 = 1 To 81
a1(i1) = Sheets("MgcLns9").Cells(j1, i1).Value
Next i1
For i1 = 1 To 81
If a(i1) <> a1(i1) Then fl1 = 0: Return
Next i1
Return
' Select Model
900
Select Case j30
Case 1 ' Model B1
b1(1)=b(1): b1(2)=b(2): b1(3)=b(3): b1(4)=b(5): b1(5)=b(6): b1(6)=b(4): b1(7)=b(9): b1(8)=b(7):b1(9)=b(8):
b1(10)=b(4):b1(11)=b(5):b1(12)=b(6):b1(13)=b(8):b1(14)=b(9):b1(15)=b(7):b1(16)=b(3):b1(17)=b(1):b1(18)=b(2):
b1(19)=b(7):b1(20)=b(8):b1(21)=b(9):b1(22)=b(2):b1(23)=b(3):b1(24)=b(1):b1(25)=b(6):b1(26)=b(4):b1(27)=b(5):
b1(28)=b(2):b1(29)=b(3):b1(30)=b(1):b1(31)=b(6):b1(32)=b(4):b1(33)=b(5):b1(34)=b(7):b1(35)=b(8):b1(36)=b(9):
b1(37)=b(5):b1(38)=b(6):b1(39)=b(4):b1(40)=b(9):b1(41)=b(7):b1(42)=b(8):b1(43)=b(1):b1(44)=b(2):b1(45)=b(3):
b1(46)=b(8):b1(47)=b(9):b1(48)=b(7):b1(49)=b(3):b1(50)=b(1):b1(51)=b(2):b1(52)=b(4):b1(53)=b(5):b1(54)=b(6):
b1(55)=b(3):b1(56)=b(1):b1(57)=b(2):b1(58)=b(4):b1(59)=b(5):b1(60)=b(6):b1(61)=b(8):b1(62)=b(9):b1(63)=b(7):
b1(64)=b(6):b1(65)=b(4):b1(66)=b(5):b1(67)=b(7):b1(68)=b(8):b1(69)=b(9):b1(70)=b(2):b1(71)=b(3):b1(72)=b(1):
b1(73)=b(9):b1(74)=b(7):b1(75)=b(8):b1(76)=b(1):b1(77)=b(2):b1(78)=b(3):b1(79)=b(5):b1(80)=b(6):b1(81)=b(4):
Case2 ' ModelB2
b2(1)=b(1): b2(2)=b(2): b2(3)=b(3): b2(4)=b(7): b2(5)=b(8): b2(6)=b(9): b2(7)=b(4): b2(8)=b(5):b2(9)=b(6):
b2(10)=b(4):b2(11)=b(5):b2(12)=b(6):b2(13)=b(1):b2(14)=b(2):b2(15)=b(3):b2(16)=b(7):b2(17)=b(8):b2(18)=b(9):
b2(19)=b(7):b2(20)=b(8):b2(21)=b(9):b2(22)=b(4):b2(23)=b(5):b2(24)=b(6):b2(25)=b(1):b2(26)=b(2):b2(27)=b(3):
b2(28)=b(6):b2(29)=b(4):b2(30)=b(5):b2(31)=b(3):b2(32)=b(1):b2(33)=b(2):b2(34)=b(9):b2(35)=b(7):b2(36)=b(8):
b2(37)=b(9):b2(38)=b(7):b2(39)=b(8):b2(40)=b(6):b2(41)=b(4):b2(42)=b(5):b2(43)=b(3):b2(44)=b(1):b2(45)=b(2):
b2(46)=b(3):b2(47)=b(1):b2(48)=b(2):b2(49)=b(9):b2(50)=b(7):b2(51)=b(8):b2(52)=b(6):b2(53)=b(4):b2(54)=b(5):
b2(55)=b(8):b2(56)=b(9):b2(57)=b(7):b2(58)=b(5):b2(59)=b(6):b2(60)=b(4):b2(61)=b(2):b2(62)=b(3):b2(63)=b(1):
b2(64)=b(2):b2(65)=b(3):b2(66)=b(1):b2(67)=b(8):b2(68)=b(9):b2(69)=b(7):b2(70)=b(5):b2(71)=b(6):b2(72)=b(4):
b2(73)=b(5):b2(74)=b(6):b2(75)=b(4):b2(76)=b(2):b2(77)=b(3):b2(78)=b(1):b2(79)=b(8):b2(80)=b(9):b2(81)=b(7):
Case3 ' ModelB3
b1(1)=b(1): b1(2)=b(2): b1(3)=b(3): b1(4)=b(5): b1(5)=b(6): b1(6)=b(4): b1(7)=b(9): b1(8)=b(7):b1(9)=b(8):
b1(10)=b(4):b1(11)=b(5):b1(12)=b(6):b1(13)=b(8):b1(14)=b(9):b1(15)=b(7):b1(16)=b(3):b1(17)=b(1):b1(18)=b(2):
b1(19)=b(7):b1(20)=b(8):b1(21)=b(9):b1(22)=b(2):b1(23)=b(3):b1(24)=b(1):b1(25)=b(6):b1(26)=b(4):b1(27)=b(5):
b1(28)=b(8):b1(29)=b(9):b1(30)=b(7):b1(31)=b(3):b1(32)=b(1):b1(33)=b(2):b1(34)=b(4):b1(35)=b(5):b1(36)=b(6):
b1(37)=b(2):b1(38)=b(3):b1(39)=b(1):b1(40)=b(6):b1(41)=b(4):b1(42)=b(5):b1(43)=b(7):b1(44)=b(8):b1(45)=b(9):
b1(46)=b(5):b1(47)=b(6):b1(48)=b(4):b1(49)=b(9):b1(50)=b(7):b1(51)=b(8):b1(52)=b(1):b1(53)=b(2):b1(54)=b(3):
b1(55)=b(6):b1(56)=b(4):b1(57)=b(5):b1(58)=b(7):b1(59)=b(8):b1(60)=b(9):b1(61)=b(2):b1(62)=b(3):b1(63)=b(1):
b1(64)=b(9):b1(65)=b(7):b1(66)=b(8):b1(67)=b(1):b1(68)=b(2):b1(69)=b(3):b1(70)=b(5):b1(71)=b(6):b1(72)=b(4):
b1(73)=b(3):b1(74)=b(1):b1(75)=b(2):b1(76)=b(4):b1(77)=b(5):b1(78)=b(6):b1(79)=b(8):b1(80)=b(9):b1(81)=b(7):
Case4 ' ModelB4
b2(1)=b(1): b2(2)=b(2): b2(3)=b(3): b2(4)=b(9): b2(5)=b(7): b2(6)=b(8): b2(7)=b(5): b2(8)=b(6): b2(9)=b(4):
b2(10)=b(4):b2(11)=b(5):b2(12)=b(6):b2(13)=b(3):b2(14)=b(1):b2(15)=b(2):b2(16)=b(8):b2(17)=b(9):b2(18)=b(7):
b2(19)=b(7):b2(20)=b(8):b2(21)=b(9):b2(22)=b(6):b2(23)=b(4):b2(24)=b(5):b2(25)=b(2):b2(26)=b(3):b2(27)=b(1):
b2(28)=b(6):b2(29)=b(4):b2(30)=b(5):b2(31)=b(2):b2(32)=b(3):b2(33)=b(1):b2(34)=b(7):b2(35)=b(8):b2(36)=b(9):
b2(37)=b(9):b2(38)=b(7):b2(39)=b(8):b2(40)=b(5):b2(41)=b(6):b2(42)=b(4):b2(43)=b(1):b2(44)=b(2):b2(45)=b(3):
b2(46)=b(3):b2(47)=b(1):b2(48)=b(2):b2(49)=b(8):b2(50)=b(9):b2(51)=b(7):b2(52)=b(4):b2(53)=b(5):b2(54)=b(6):
b2(55)=b(8):b2(56)=b(9):b2(57)=b(7):b2(58)=b(4):b2(59)=b(5):b2(60)=b(6):b2(61)=b(3):b2(62)=b(1):b2(63)=b(2):
b2(64)=b(2):b2(65)=b(3):b2(66)=b(1):b2(67)=b(7):b2(68)=b(8):b2(69)=b(9):b2(70)=b(6):b2(71)=b(4):b2(72)=b(5):
b2(73)=b(5):b2(74)=b(6):b2(75)=b(4):b2(76)=b(1):b2(77)=b(2):b2(78)=b(3):b2(79)=b(9):b2(80)=b(7):b2(81)=b(8):
Case5 ' ModelB5
b1(1)=b(1): b1(2)=b(2): b1(3)=b(3): b1(4)=b(4): b1(5)=b(5): b1(6)=b(6): b1(7)=b(7): b1(8)=b(8): b1(9)=b(9):
b1(10)=b(4):b1(11)=b(5):b1(12)=b(6):b1(13)=b(7):b1(14)=b(8):b1(15)=b(9):b1(16)=b(1):b1(17)=b(2):b1(18)=b(3):
b1(19)=b(7):b1(20)=b(8):b1(21)=b(9):b1(22)=b(1):b1(23)=b(2):b1(24)=b(3):b1(25)=b(4):b1(26)=b(5):b1(27)=b(6):
b1(28)=b(3):b1(29)=b(1):b1(30)=b(2):b1(31)=b(6):b1(32)=b(4):b1(33)=b(5):b1(34)=b(9):b1(35)=b(7):b1(36)=b(8):
b1(37)=b(6):b1(38)=b(4):b1(39)=b(5):b1(40)=b(9):b1(41)=b(7):b1(42)=b(8):b1(43)=b(3):b1(44)=b(1):b1(45)=b(2):
b1(46)=b(9):b1(47)=b(7):b1(48)=b(8):b1(49)=b(3):b1(50)=b(1):b1(51)=b(2):b1(52)=b(6):b1(53)=b(4):b1(54)=b(5):
b1(55)=b(2):b1(56)=b(3):b1(57)=b(1):b1(58)=b(5):b1(59)=b(6):b1(60)=b(4):b1(61)=b(8):b1(62)=b(9):b1(63)=b(7):
b1(64)=b(5):b1(65)=b(6):b1(66)=b(4):b1(67)=b(8):b1(68)=b(9):b1(69)=b(7):b1(70)=b(2):b1(71)=b(3):b1(72)=b(1):
b1(73)=b(8):b1(74)=b(9):b1(75)=b(7):b1(76)=b(2):b1(77)=b(3):b1(78)=b(1):b1(79)=b(5):b1(80)=b(6):b1(81)=b(4):
Case6 ' ModelB6
b2(1)=b(1): b2(2)=b(2): b2(3)=b(3): b2(4)=b(7): b2(5)=b(8): b2(6)=b(9): b2(7)=b(4): b2(8)=b(5): b2(9)=b(6):
b2(10)=b(4):b2(11)=b(5):b2(12)=b(6):b2(13)=b(1):b2(14)=b(2):b2(15)=b(3):b2(16)=b(7):b2(17)=b(8):b2(18)=b(9):
b2(19)=b(7):b2(20)=b(8):b2(21)=b(9):b2(22)=b(4):b2(23)=b(5):b2(24)=b(6):b2(25)=b(1):b2(26)=b(2):b2(27)=b(3):
b2(28)=b(2):b2(29)=b(3):b2(30)=b(1):b2(31)=b(8):b2(32)=b(9):b2(33)=b(7):b2(34)=b(5):b2(35)=b(6):b2(36)=b(4):
b2(37)=b(5):b2(38)=b(6):b2(39)=b(4):b2(40)=b(2):b2(41)=b(3):b2(42)=b(1):b2(43)=b(8):b2(44)=b(9):b2(45)=b(7):
b2(46)=b(8):b2(47)=b(9):b2(48)=b(7):b2(49)=b(5):b2(50)=b(6):b2(51)=b(4):b2(52)=b(2):b2(53)=b(3):b2(54)=b(1):
b2(55)=b(3):b2(56)=b(1):b2(57)=b(2):b2(58)=b(9):b2(59)=b(7):b2(60)=b(8):b2(61)=b(6):b2(62)=b(4):b2(63)=b(5):
b2(64)=b(6):b2(65)=b(4):b2(66)=b(5):b2(67)=b(3):b2(68)=b(1):b2(69)=b(2):b2(70)=b(9):b2(71)=b(7):b2(72)=b(8):
b2(73)=b(9):b2(74)=b(7):b2(75)=b(8):b2(76)=b(6):b2(77)=b(4):b2(78)=b(5):b2(79)=b(3):b2(80)=b(1):b2(81)=b(2):
End Select
Return
' Check identical numbers
300 fl1 = 1
For i1 = 1 To 81
a2 = a(i1)
For i2 = (1 + i1) To 81
If a2 = a(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
' Construct Square c() (Squared Elements)
400 For i1 = 1 To 81
c(i1) = a(i1) ^ 2
Next i1
Return
' Check Magic Sum c()
500 fl1 = 1
s9(1) = c(1) + c(2) + c(3) + c(4) + c(5) + c(6) + c(7) + c(8) + c(9)
s9(2) = c(10) + c(11) + c(12) + c(13) + c(14) + c(15) + c(16) + c(17) + c(18)
s9(3) = c(19) + c(20) + c(21) + c(22) + c(23) + c(24) + c(25) + c(26) + c(27)
s9(4) = c(28) + c(29) + c(30) + c(31) + c(32) + c(33) + c(34) + c(35) + c(36)
s9(5) = c(37) + c(38) + c(39) + c(40) + c(41) + c(42) + c(43) + c(44) + c(45)
s9(6) = c(46) + c(47) + c(48) + c(49) + c(50) + c(51) + c(52) + c(53) + c(54)
s9(7) = c(55) + c(56) + c(57) + c(58) + c(59) + c(60) + c(61) + c(62) + c(63)
s9(8) = c(64) + c(65) + c(66) + c(67) + c(68) + c(69) + c(70) + c(71) + c(72)
s9(9) = c(73) + c(74) + c(75) + c(76) + c(77) + c(78) + c(79) + c(80) + c(81)
s9(10) = c(1) + c(10) + c(19) + c(28) + c(37) + c(46) + c(55) + c(64) + c(73)
s9(11) = c(2) + c(11) + c(20) + c(29) + c(38) + c(47) + c(56) + c(65) + c(74)
s9(12) = c(3) + c(12) + c(21) + c(30) + c(39) + c(48) + c(57) + c(66) + c(75)
s9(13) = c(4) + c(13) + c(22) + c(31) + c(40) + c(49) + c(58) + c(67) + c(76)
s9(14) = c(5) + c(14) + c(23) + c(32) + c(41) + c(50) + c(59) + c(68) + c(77)
s9(15) = c(6) + c(15) + c(24) + c(33) + c(42) + c(51) + c(60) + c(69) + c(78)
s9(16) = c(7) + c(16) + c(25) + c(34) + c(43) + c(52) + c(61) + c(70) + c(79)
s9(17) = c(8) + c(17) + c(26) + c(35) + c(44) + c(53) + c(62) + c(71) + c(80)
s9(18) = c(9) + c(18) + c(27) + c(36) + c(45) + c(54) + c(63) + c(72) + c(81)
s9(19) = c(1) + c(11) + c(21) + c(31) + c(41) + c(51) + c(61) + c(71) + c(81)
s9(20) = c(9) + c(17) + c(25) + c(33) + c(41) + c(49) + c(57) + c(65) + c(73)
' Regular Sub Squares (Optional)
s9(21) = c(1) + c(2) + c(3) + c(10) + c(11) + c(12) + c(19) + c(20) + c(21)
s9(22) = c(4) + c(5) + c(6) + c(13) + c(14) + c(15) + c(22) + c(23) + c(24)
s9(23) = c(7) + c(8) + c(9) + c(16) + c(17) + c(18) + c(25) + c(26) + c(27)
s9(24) = c(28) + c(29) + c(30) + c(37) + c(38) + c(39) + c(46) + c(47) + c(48)
s9(25) = c(31) + c(32) + c(33) + c(40) + c(41) + c(42) + c(49) + c(50) + c(51)
s9(26) = c(34) + c(35) + c(36) + c(43) + c(44) + c(45) + c(52) + c(53) + c(54)
s9(27) = c(55) + c(56) + c(57) + c(64) + c(65) + c(66) + c(73) + c(74) + c(75)
s9(28) = c(58) + c(59) + c(60) + c(67) + c(68) + c(69) + c(76) + c(77) + c(78)
s9(29) = c(61) + c(62) + c(63) + c(70) + c(71) + c(72) + c(79) + c(80) + c(81)
For i1 = 1 To 29 ''20
If s9(i1) <> 20049 Then fl1 = 0: Return
Next i1
Return
' Print results (selected numbers)
740 Cells(n9, 81).Select
For i1 = 1 To 81
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 82).Value = j1
'' Cells(n9, 83).Value = j2
Return
' Print results (squares)
750 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 10: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 10
End If
'' Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
Cells(k1, k2 + 2).Value = j1
'' Cells(k1, k2 + 3).Value = j2
i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
