' Generates Sudoku Comparable Simple Magic Cubes of order 4 for integers 0 thru 3
' Horizontal Pan Magic Planes (3D-Compact)
' Tested with Office 2007 under Windows 7
Sub SudCube42()
Dim a(64), b(4)
y = MsgBox("Locked", vbCritical, "Routine SudCube42")
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
a(59) = s1 - a(60) - a(63) - a(64): If a(59) < m1 Or a(59) > m2 Then GoTo 600
a(58) = a(60) - a(62) + a(64): If a(58) < m1 Or a(58) > m2 Then GoTo 600
a(57) = - a(60) + a(62) + a(63): If a(57) < m1 Or a(57) > m2 Then GoTo 600
For j48 = m1 To m2 'a(48)
a(48) = j48
a(45) = - a(48) + a(62) + a(63): If a(45) < m1 Or a(45) > m2 Then GoTo 480
a(43) = - a(48) + a(60) + a(63): If a(43) < m1 Or a(43) > m2 Then GoTo 480
a(42) = a(48) - a(60) + a(62): If a(42) < m1 Or a(42) > m2 Then GoTo 480
For j47 = m1 To m2 'a(47)
a(47) = j47
a(46) = s1 - a(47) - a(62) - a(63): If a(46) < m1 Or a(46) > m2 Then GoTo 470
a(44) = s1 - a(47) - a(60) - a(63): If a(44) < m1 Or a(44) > m2 Then GoTo 470
a(41) = a(47) + a(60) - a(62): If a(41) < m1 Or a(41) > m2 Then GoTo 470
For j32 = m1 To m2 'a(32)
a(32) = j32
a(27) = a(32) + 2 * a(48) - a(60) - a(63):
If a(27) < m1 Or a(27) > m2 Then GoTo 320
a(16) = s1 - a(32) - a(48) - a(64): If a(16) < m1 Or a(16) > m2 Then GoTo 320
a(11) = s1 - a(27) - a(43) - a(59): If a(11) < m1 Or a(11) > m2 Then GoTo 320
For j31 = m1 To m2 'a(31)
a(31) = j31
a(28) = s1 - a(31) - 2 * a(32) + a(43) - a(48):
If a(28) < m1 Or a(28) > m2 Then GoTo 310
a(15) = s1 - a(31) - a(47) - a(63): If a(15) < m1 Or a(15) > m2 Then GoTo 310
a(12) = s1 - a(28) - a(44) - a(60): If a(12) < m1 Or a(12) > m2 Then GoTo 310
For j30 = m1 To m2 'a(30)
a(30) = j30
a(29) = s1 - a(30) - a(31) - a(32): If a(29) < m1 Or a(29) > m2 Then GoTo 300
a(26) = a(29) - 2 * a(48) + a(60) + a(63):
If a(26) < m1 Or a(26) > m2 Then GoTo 300
a(25) = s1 - a(26) - a(27) - a(28): If a(25) < m1 Or a(25) > m2 Then GoTo 300
a(14) = - a(30) + a(47) + a(63): If a(14) < m1 Or a(14) > m2 Then GoTo 300
a(13) = s1 - a(14) - a(15) - a(16): If a(13) < m1 Or a(13) > m2 Then GoTo 300
a(10) = s1 - a(26) - a(42) - a(58): If a(10) < m1 Or a(10) > m2 Then GoTo 300
a(9) = s1 - a(10) - a(11) - a(12): If a(9) < m1 Or a(9) > m2 Then GoTo 300
a(56) = s1/2 - a(62): a(40) = s1/2 - a(46): a(24) = s1/2 - a(30): a(8) = s1/2 - a(14)
a(55) = s1/2 - a(61): a(39) = s1/2 - a(45): a(23) = s1/2 - a(29): a(7) = s1/2 - a(13)
a(54) = s1/2 - a(64): a(38) = s1/2 - a(48): a(22) = s1/2 - a(32): a(6) = s1/2 - a(16)
a(53) = s1/2 - a(63): a(37) = s1/2 - a(47): a(21) = s1/2 - a(31): a(5) = s1/2 - a(15)
a(52) = s1/2 - a(58): a(36) = s1/2 - a(42): a(20) = s1/2 - a(26): a(4) = s1/2 - a(10)
a(51) = s1/2 - a(57): a(35) = s1/2 - a(41): a(19) = s1/2 - a(25): a(3) = s1/2 - a(9)
a(50) = s1/2 - a(60): a(34) = s1/2 - a(44): a(18) = s1/2 - a(28): a(2) = s1/2 - a(12)
a(49) = s1/2 - a(59): a(33) = s1/2 - a(43): a(17) = s1/2 - a(27): a(1) = s1/2 - a(11)
' Exclude solutions with identical numbers in rows, colums or pillars
GoSub 800: If fl1 = 0 Then GoTo 300 'rows, colums or pillars
n9 = n9 + 1: GoSub 740 'Print results (selected numbers)
' n9 = n9 + 1: GoSub 750 'Print results (planes 1, 2, 3, 4)
300 Next j30
310 Next j31
320 Next j32
470 Next j47
480 Next j48
600 Next j60
620 Next j62
630 Next j63
640 Next j64
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine SudCube42")
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
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
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
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
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
