About the Author

' Non-associated Pantriagonal Magic Cubes, Complete (m = 6)

' Tested with Office 2007 under Windows 7

Sub CnstrPntr6()

y = MsgBox("Locked", vbCritical, "Routine CnstrPntr6")
End

Sheets("Klad1").Select

Dim F6(3, 4)

F6(1, 1) = 0:  F6(1, 2) = 1:  F6(1, 3) = 2:  F6(1, 4) = 3:
F6(2, 1) = 4:  F6(2, 2) = 5:  F6(2, 3) = 6:  F6(2, 4) = 7:
F6(3, 1) = 14: F6(3, 2) = 12: F6(3, 3) = 10: F6(3, 4) = 8:

m = 6

n9 = 0
For k = 0 To m - 1
For i = 0 To m - 1
i1 = i1 + 1
For j = 0 To m - 1
j1 = j1 + 1: j2 = j2 + 1

        
    b = i + j + k
    c = i - j + k
    If c < 0 Then c = c + m
    d = i + j - k
    If d < 0 Then d = d + m
    
    b1 = b Mod (m / 2)
    c1 = c Mod (m / 2)
    d1 = d Mod (m / 2)
    
    If k < m / 2 Then
        q1 = 2 * Int(2 * i / m) + Int(2 * j / m)
    Else
        q1 = m / 2 - 2 * Int(2 * i / m) - Int(2 * j / m)
    End If
    
    z1 = Int(2 * i / m) + Int(2 * j / m) + Int(2 * k / m)
    a1 = F6(b1 + 1, q1 + 1) * (m / 2) ^ 2 + c1 * (m / 2) + d1 + 1
    If Int(z1 / 2) = z1 / 2 Then 'z1 is even
        a = a1
    Else
        a = m ^ 3 + 1 - a1
    End If

'   Print Cube

    If j1 = m + 1 Then j1 = 1
    If j2 = m ^ 2 + 1 Then j2 = 1: i1 = i1 + 1
    Cells(i1 + 1, j1 + 1).Value = a

'   print Components

'   Cells(i1 + 1, j1 + 1 + 9).Value = F6(b1 + 1, q1 + 1)
'   Cells(i1 + 1, j1 + 1 + 18).Value = b1
'   Cells(i1 + 1, j1 + 1 + 27).Value = q1

Next j
Next i
Next k

End Sub

About the Author