' Generates Pantriagonal/Associated Sudoku Comparable Magic Cubes of order 4 for integers 0 thru 3
' Tested with Office 2007 under Windows 7
Sub SudCube4e()
Dim a(64), b(4)
y = MsgBox("Locked", vbCritical, "Routine SudCube4e")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 3: s1 = 6
' Generate data
Sheets("Klad1").Select
t1 = Timer
For j64 = m1 To m2 'a(64)
a(64) = j64
For j63 = m1 To m2 'a(63)
a(63) = j63
For j62 = m1 To m2 'a(62)
a(62) = j62
a(61) = s1 - a(62) - a(63) - a(64): If a(61) < m1 Or a(61) > m2 Then GoTo 620
For j60 = m1 To m2 'a(60)
a(60) = j60
For j59 = m1 To m2 'a(59)
a(59) = j59
For j58 = m1 To m2 'a(58)
a(58) = j58
a(57) = s1 - a(58) - a(59) - a(60): If a(57) < m1 Or a(57) > m2 Then GoTo 580
For j56 = m1 To m2 'a(56)
a(56) = j56
a(55) = a(56) + a(58) + a(60) - a(62) - a(63): If a(55) < m1 Or a(55) > m2 Then GoTo 560
a(54) = s1 - a(56) - a(58) - a(60): If a(54) < m1 Or a(54) > m2 Then GoTo 560
a(53) = -a(56) + a(62) + a(63): If a(53) < m1 Or a(53) > m2 Then GoTo 560
a(52) = s1 - a(56) - a(60) - a(64): If a(52) < m1 Or a(52) > m2 Then GoTo 560
a(51) = s1 - a(56) - a(58) - a(59) - a(60) + a(62): If a(51) < m1 Or a(51) > m2 Then GoTo 560
a(50) = a(56) + a(60) - a(62): If a(50) < m1 Or a(50) > m2 Then GoTo 560
a(49) = -s1 + a(56) + a(58) + a(59) + a(60) + a(64): If a(49) < m1 Or a(49) > m2 Then GoTo 560
For j48 = m1 To m2 'a(48)
a(48) = j48
a(47) = -a(48) + a(59) + a(60): If a(47) < m1 Or a(47) > m2 Then GoTo 480
a(46) = s1 + a(48) - a(58) - 2 * a(59) - a(60): If a(46) < m1 Or a(46) > m2 Then GoTo 480
a(45) = -a(48) + a(58) + a(59): If a(45) < m1 Or a(45) > m2 Then GoTo 480
a(44) = -a(48) + a(59) + a(63): If a(44) < m1 Or a(44) > m2 Then GoTo 480
a(43) = a(48) - a(59) + a(64): If a(43) < m1 Or a(43) > m2 Then GoTo 480
a(42) = s1 - a(48) + a(59) - a(62) - a(63) - a(64): If a(42) < m1 Or a(42) > m2 Then GoTo 480
a(41) = a(48) - a(59) + a(62): If a(41) < m1 Or a(41) > m2 Then GoTo 480
a(40) = s1 + a(48) - a(56) - a(58) - 2 * a(59) - a(60) + a(62): If a(40) < m1 Or a(40) > m2 Then GoTo 480
a(39) = s1 - a(48) - a(56) + a(59) - a(60) - a(64): If a(39) < m1 Or a(39) > m2 Then GoTo 480
a(38) = -s1 + a(48) + a(56) + a(58) + a(60) + a(64): If a(38) < m1 Or a(38) > m2 Then GoTo 480
a(37) = -a(48) + a(56) + a(59) + a(60) - a(62): If a(37) < m1 Or a(37) > m2 Then GoTo 480
a(36) = -a(48) + a(56) + a(58) + a(59) + a(60) - a(62) - a(63): If a(36) < m1 Or a(36) > m2 Then GoTo 480
a(35) = a(48) + a(56) - a(59): If a(35) < m1 Or a(35) > m2 Then GoTo 480
a(34) = -a(48) - a(56) + a(59) + a(62) + a(63): If a(34) < m1 Or a(34) > m2 Then GoTo 480
a(33) = s1 + a(48) - a(56) - a(58) - a(59) - a(60): If a(33) < m1 Or a(33) > m2 Then GoTo 480
a(32) = s1 / 2 - a(33): a(31) = s1 / 2 - a(34): a(30) = s1 / 2 - a(35): a(29) = s1 / 2 - a(36)
a(28) = s1 / 2 - a(37): a(27) = s1 / 2 - a(38): a(26) = s1 / 2 - a(39): a(25) = s1 / 2 - a(40)
a(24) = s1 / 2 - a(41): a(23) = s1 / 2 - a(42): a(22) = s1 / 2 - a(43): a(21) = s1 / 2 - a(44)
a(20) = s1 / 2 - a(45): a(19) = s1 / 2 - a(46): a(18) = s1 / 2 - a(47): a(17) = s1 / 2 - a(48)
a(16) = s1 / 2 - a(49): a(15) = s1 / 2 - a(50): a(14) = s1 / 2 - a(51): a(13) = s1 / 2 - a(52)
a(12) = s1 / 2 - a(53): a(11) = s1 / 2 - a(54): a(10) = s1 / 2 - a(55): a(9) = s1 / 2 - a(56)
a(8) = s1 / 2 - a(57): a(7) = s1 / 2 - a(58): a(6) = s1 / 2 - a(59): a(5) = s1 / 2 - a(60)
a(4) = s1 / 2 - a(61): a(3) = s1 / 2 - a(62): a(2) = s1 / 2 - a(63): a(1) = s1 / 2 - a(64)
' Exclude solutions with identical numbers in rows, colums or pillars
GoSub 800: If fl1 = 0 Then GoTo 480
n9 = n9 + 1: GoSub 740 'Print results (selected numbers)
' n9 = n9 + 1: GoSub 750 'Print results (planes 1, 2, 3, 4)
480 Next j48
560 Next j56
580 Next j58
Next j59
Next j60
620 Next j62
Next j63
Next j64
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine SudCube4e")
End
' Print results (selected numbers)
740 For i1 = 1 To 64
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 64).Select
Return
' Print results (planes 11, 12, 13 and 14)
750 n2 = n2 + 1
If n2 = 9 Then
n2 = 1: k1 = k1 + 20: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 5
End If
For i0 = 1 To 4
i3 = (4 - i0) * 16
For i1 = 1 To 4
For i2 = 1 To 4
i3 = i3 + 1
Cells(k1 + i1 + (i0 - 1) * 5, k2 + i2).Value = a(i3)
Next i2
Next i1
Cells(k1 + (i0 - 1) * 5, k2 + 1).Value = "Plane 1" + CStr(i0)
Next i0
Return
' Exclude solutions with identical numbers in rows, colums or pillars
800 fl1 = 1
' Rows
i1 = -3
For i0 = 1 To 16
i1 = i1 + 4
b(1) = a(i1): b(2) = a(i1 + 1): b(3) = a(i1 + 2): b(4) = a(i1 + 3)
GoSub 860
If fl1 = 0 Then Return
Next i0
' Columns
i1 = 0: i2 = 0
For i0 = 1 To 16
i1 = i1 + 1
b(1) = a(i1): b(2) = a(i1 + 4): b(3) = a(i1 + 8): b(4) = a(i1 + 12)
i2 = i2 + 1: If i2 = 4 Then i2 = 0: i1 = i1 + 12
GoSub 860
If fl1 = 0 Then Return
Next i0
' Pillars
i1 = 0: i2 = 0
For i0 = 1 To 16
i1 = i0
b(1) = a(i1): b(2) = a(i1 + 16): b(3) = a(i1 + 32): b(4) = a(i1 + 48)
GoSub 860
If fl1 = 0 Then Return
Next i0
850 Return
860 fl1 = 1
For j1 = 1 To 4
b2 = b(j1)
For j2 = (1 + j1) To 4
If b2 = b(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
End Sub
