' Generates Composed Magic Squares of order 13 based on Sub Square Collections
' Tested with Office 2007 under Windows 7
Sub CmbSqr13()
Dim a(169), SqrNr1(8)
Dim a1(16), b1(16), c1(25), d1(16), e1(16), g1(25), i10(49), h1(81)
y = MsgBox("Locked", vbCritical, "Routine CmbSqr13")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 169: s1 = 1105
Sheets("Solutions1267").Select
t1 = Timer
For j1 = 2 To 61
n9 = n9 + 1
For j2 = 1 To 8
SqrNr1(j2) = Sheets("Index1").Cells(j1, j2 + 1).Value
Next j2
j10 = SqrNr1(3)
If n9 <= 36 Then
Sht1 = "Solutions1261"
Else
Sht1 = "Solutions1262"
End If
GoSub 100 'Read Center Square C
j10 = SqrNr1(6): Sht1 = "Solutions1263"
GoSub 200 'Read Center Square G
j10 = SqrNr1(1): Sht1 = "Solutions1264"
GoSub 310 'Read Center Square A
j10 = SqrNr1(2) + 16: Sht1 = "Solutions1264"
GoSub 320 'Read Center Square B
j10 = SqrNr1(4) + 32: Sht1 = "Solutions1264"
GoSub 330 'Read Center Square D
j10 = SqrNr1(5) + 48: Sht1 = "Solutions1264"
GoSub 340 'Read Center Square E
j10 = SqrNr1(7): Sht1 = "Solutions1265"
GoSub 400 'Read Center Square I
j10 = SqrNr1(8): Sht1 = "Solutions1266"
GoSub 500 'Read Center Square H
GoSub 2650 'Print Square J (13 x 13)
Next j1
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CmbSqr13")
End
' Read Center Square C (5 x 5)
100 k11 = Int((j10 - 1) / 4)
k12 = j10 - k11 * 4
k21 = 1 + k11 * 6
k22 = 1 + (k12 - 1) * 6
i3 = 0
For i1 = 1 To 5
For i2 = 1 To 5
i3 = i3 + 1
c1(i3) = Sheets(Sht1).Cells(k21 + i1, k22 + i2).Value
Next i2
Next i1
a(57) = c1(1): a(58) = c1(2): a(59) = c1(3): a(60) = c1(4): a(61) = c1(5):
a(70) = c1(6): a(71) = c1(7): a(72) = c1(8): a(73) = c1(9): a(74) = c1(10):
a(83) = c1(11): a(84) = c1(12): a(85) = c1(13): a(86) = c1(14): a(87) = c1(15):
a(96) = c1(16): a(97) = c1(17): a(98) = c1(18): a(99) = c1(19): a(100) = c1(20):
a(109) = c1(21): a(110) = c1(22): a(111) = c1(23): a(112) = c1(24): a(113) = c1(25):
Return
' Read Coner Square G (5 x 5)
200 k11 = Int((j10 - 1) / 4)
k12 = j10 - k11 * 4
k21 = 1 + k11 * 6
k22 = 1 + (k12 - 1) * 6
i3 = 0
For i1 = 1 To 5
For i2 = 1 To 5
i3 = i3 + 1
g1(i3) = Sheets(Sht1).Cells(k21 + i1, k22 + i2).Value
Next i2
Next i1
a(105) = g1(1): a(106) = g1(2): a(107) = g1(3): a(108) = g1(4): a(109) = g1(5):
a(118) = g1(6): a(119) = g1(7): a(120) = g1(8): a(121) = g1(9): a(122) = g1(10):
a(131) = g1(11): a(132) = g1(12): a(133) = g1(13): a(134) = g1(14): a(135) = g1(15):
a(144) = g1(16): a(145) = g1(17): a(146) = g1(18): a(147) = g1(19): a(148) = g1(20):
a(157) = g1(21): a(158) = g1(22): a(159) = g1(23): a(160) = g1(24): a(161) = g1(25):
Return
' Read Border Square A (4 x 4)
310 k11 = Int((j10 - 1) / 4)
k12 = j10 - k11 * 4
k21 = 1 + k11 * 5
k22 = 1 + (k12 - 1) * 5
i3 = 0
For i1 = 1 To 4
For i2 = 1 To 4
i3 = i3 + 1
a1(i3) = Sheets(Sht1).Cells(k21 + i1, k22 + i2).Value
Next i2
Next i1
a(1) = a1(1): a(2) = a1(2): a(3) = a1(3): a(4) = a1(4):
a(14) = a1(5): a(15) = a1(6): a(16) = a1(7): a(17) = a1(8):
a(27) = a1(9): a(28) = a1(10): a(29) = a1(11): a(30) = a1(12):
a(40) = a1(13): a(41) = a1(14): a(42) = a1(15): a(43) = a1(16):
Return
' Read Border Square B (4 x 4)
320 k11 = Int((j10 - 1) / 4)
k12 = j10 - k11 * 4
k21 = 1 + k11 * 5
k22 = 1 + (k12 - 1) * 5
i3 = 0
For i1 = 1 To 4
For i2 = 1 To 4
i3 = i3 + 1
b1(i3) = Sheets(Sht1).Cells(k21 + i1, k22 + i2).Value
Next i2
Next i1
a(53) = b1(1): a(54) = b1(2): a(55) = b1(3): a(56) = b1(4):
a(66) = b1(5): a(67) = b1(6): a(68) = b1(7): a(69) = b1(8):
a(79) = b1(9): a(80) = b1(10): a(81) = b1(11): a(82) = b1(12):
a(92) = b1(13): a(93) = b1(14): a(94) = b1(15): a(95) = b1(16):
Return
' Read Border Square D (4 x 4)
330 k11 = Int((j10 - 1) / 4)
k12 = j10 - k11 * 4
k21 = 1 + k11 * 5
k22 = 1 + (k12 - 1) * 5
i3 = 0
For i1 = 1 To 4
For i2 = 1 To 4
i3 = i3 + 1
d1(i3) = Sheets(Sht1).Cells(k21 + i1, k22 + i2).Value
Next i2
Next i1
a(123) = d1(1): a(124) = d1(2): a(125) = d1(3): a(126) = d1(4):
a(136) = d1(5): a(137) = d1(6): a(138) = d1(7): a(139) = d1(8):
a(149) = d1(9): a(150) = d1(10): a(151) = d1(11): a(152) = d1(12):
a(162) = d1(13): a(163) = d1(14): a(164) = d1(15): a(165) = d1(16):
Return
' Read Border Square E (4 x 4)
340 k11 = Int((j10 - 1) / 4)
k12 = j10 - k11 * 4
k21 = 1 + k11 * 5
k22 = 1 + (k12 - 1) * 5
i3 = 0
For i1 = 1 To 4
For i2 = 1 To 4
i3 = i3 + 1
e1(i3) = Sheets(Sht1).Cells(k21 + i1, k22 + i2).Value
Next i2
Next i1
a(127) = e1(1): a(128) = e1(2): a(129) = e1(3): a(130) = e1(4):
a(140) = e1(5): a(141) = e1(6): a(142) = e1(7): a(143) = e1(8):
a(153) = e1(9): a(154) = e1(10): a(155) = e1(11): a(156) = e1(12):
a(166) = e1(13): a(167) = e1(14): a(168) = e1(15): a(169) = e1(16):
Return
' Read Border I (7 x 7)
400 k11 = Int((j10 - 1) / 4)
k12 = j10 - k11 * 4
k21 = 1 + k11 * 8
k22 = 1 + (k12 - 1) * 8
i3 = 0
For i1 = 1 To 7
For i2 = 1 To 7
i3 = i3 + 1
i10(i3) = Sheets(Sht1).Cells(k21 + i1, k22 + i2).Value
Next i2
Next i1
a(31) = i10(1): a(32) = i10(2): a(33) = i10(3): a(34) = i10(4): a(35) = i10(5): a(36) = i10(6): a(37) = i10(7):
a(44) = i10(8): a(45) = i10(9): a(46) = i10(10): a(47) = i10(11): a(48) = i10(12): a(49) = i10(13): a(50) = i10(14):
a(62) = i10(20): a(63) = i10(21):
a(75) = i10(27): a(76) = i10(28):
a(88) = i10(34): a(89) = i10(35):
a(101) = i10(41): a(102) = i10(42):
a(114) = i10(48): a(115) = i10(49):
Return
' Read border H (9 x 9)
500 k11 = Int((j10 - 1) / 4)
k12 = j10 - k11 * 4
k21 = 1 + k11 * 10
k22 = 1 + (k12 - 1) * 10
i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
i3 = i3 + 1
h1(i3) = Sheets(Sht1).Cells(k21 + i1, k22 + i2).Value
Next i2
Next i1
a(5) = h1(1): a(6) = h1(2): a(7) = h1(3): a(8) = h1(4): a(9) = h1(5): a(10) = h1(6): a(11) = h1(7): a(12) = h1(8): a(13) = h1(9):
a(18) = h1(10): a(19) = h1(11): a(20) = h1(12): a(21) = h1(13): a(22) = h1(14): a(23) = h1(15): a(24) = h1(16): a(25) = h1(17): a(26) = h1(18):
a(38) = h1(26): a(39) = h1(27):
a(51) = h1(35): a(52) = h1(36):
a(64) = h1(44): a(65) = h1(45):
a(77) = h1(53): a(78) = h1(54):
a(90) = h1(62): a(91) = h1(63):
a(103) = h1(71): a(104) = h1(72):
a(116) = h1(80): a(117) = h1(81):
Return
' Print results (squares)
2650 n2 = n2 + 1
If n2 = 3 Then
n2 = 1: k1 = k1 + 14: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 14
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 13
For i2 = 1 To 13
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
