' Associated Pandiagonal Magic Cubes (m = 15)
' Tested with Office 2007 under Windows 7
Dim R35(3, 5)
Sub PanDia23()
y = MsgBox("Locked", vbCritical, "Routine aPanDia23")
End
' Magic Rectangle R35:
''R35(1, 1) = 14: R35(1, 2) = 10: R35(1, 3) = 4: R35(1, 4) = 5: R35(1, 5) = 7:
''R35(2, 1) = 1: R35(2, 2) = 3: R35(2, 3) = 8: R35(2, 4) = 13: R35(2, 5) = 15:
''R35(3, 1) = 9: R35(3, 2) = 11: R35(3, 3) = 12: R35(3, 4) = 6: R35(3, 5) = 2:
' Read Rectangle R35 from Spreadsheet (line format)
j10 = 1 'line number 1 ... 16
k1 = 1: k2 = 0
For j20 = 1 To 15
k2 = k2 + 1: If k2 = 6 Then k2 = 1: k1 = k1 + 1
R35(k1, k2) = Sheets("R35").Cells(j10, j20).Value
t10 = t10 + CStr(R35(k1, k2)) + ", "
Next j20
Sheets("Klad1").Select
m = 15
n9 = 0: k1 = 0: k2 = 0
For i = 0 To m - 1
For j = 0 To m - 1
j1 = j1 + 1
For k = 0 To m - 1
k1 = k1 + 1: k2 = k2 + 1
b = i + 2 * j + 3 * k + ((m - 1) / 2 + 3)
c = i + 3 * j + 2 * k + ((m - 1) / 2 + 3)
d = 2 * i + 3 * j - k + ((m - 1) / 2 + 2)
If d < m Then d = d + m
b1 = b Mod m
c1 = c Mod m
d1 = d Mod m
a = S15(b1) * m ^ 2 + S15(c1) * m + S15(d1) + 1
' Print Cube
If k1 = m + 1 Then k1 = 1
If k2 = m ^ 2 + 1 Then k2 = 1: j1 = j1 + 1
Cells(j1 + 1, k1 + 1).Value = a
' Print Components
' Cells(j1 + 1, k1 + 1 + m + 1).Value = b1
' Cells(j1 + 1, k1 + 1 + 2 * (m + 1)).Value = c1
' Cells(j1 + 1, k1 + 1 + 3 * (m + 1)).Value = d1
Next k
Next j
Next i
End Sub
Function S15(x)
x1 = x Mod 3
y1 = x Mod 5
S15 = R35(x1 + 1, y1 + 1) - 1
End Function
