' Construction Associated Magic Cubes

' Tested with Office 2007 under Windows 7

```Sub CnstrCbs7()

Dim B1(343), B2(343), B3(343), C(343)
Dim a2(49), a3(49), a(7)

y = MsgBox("Blocked", 0, "CnstrCbs77")
End

n1 = 0: n9 = 0: k1 = 1: k2 = 1

For j100 = 2 To 193 'Read Hor Center Square B1 (Sudoku)

Shft7 = Sheets("SudUltra7").Cells(j100, 51).Value
MoveTo7 = Sheets("SudUltra7").Cells(j100, 52).Value

If Shft7 <> 2 Or MoveTo7 <> "Left" Then GoTo 1000  'Together with Sub 750 (Batch 1)
'   If Shft7 <> 2 Or MoveTo7 <> "Right" Then GoTo 1000 'Together with Sub 760 (Batch 2)
'   If Shft7 <> 3 Or MoveTo7 <> "Right" Then GoTo 1000 'Together with Sub 770 (Batch 3)
'   If Shft7 <> 3 Or MoveTo7 <> "Left" Then GoTo 1000  'Together with Sub 780 (Batch 4)

Erase B1
For i10 = 1 To 49
B1(i10 + 3 * 49) = Sheets("SudUltra7").Cells(j100, i10).Value
Next i10

'   Center Line of Center Square

For i10 = 1 To 7
a(i10) = B1(i10 + 21 + 3 * 49)
Next i10

For j200 = j100 + 1 To 193 'Read Vert Center Square B1 (Sudoku)

For i10 = 1 To 49
a2(i10) = Sheets("SudUltra7").Cells(j200, i10).Value
Next i10

'   Check Matching Center Lines

For i10 = 1 To 7
If a(i10) <> a2(21 + i10) Then GoTo 2000
Next i10

For i20 = 1 To 7
If i20 = 4 Then GoTo 200

Erase a3
For i10 = 1 To 7
a3(i10 + 21) = a2(i10 + (i20 - 1) * 7)
Next i10

GoSub 750                             'Fill a3()
'       GoSub 760                             'Fill a3()
'       GoSub 770                             'Fill a3()
'       GoSub 780                             'Fill a3()

For i10 = 1 To 49                     'Fill B1()
B1(i10 + (i20 - 1) * 49) = a3(i10)
Next i10

200 Next i20

GoSub 800                                 'Construct B2
GoSub 850                                 'Construct B3

'   Construct C

For i1 = 1 To 343
C(i1) = B1(i1) + 7 * B2(i1) + 7 ^ 2 * B3(i1) + 1
Next i1

'   Check Identical Numbers

GoSub 1300: If fl1 = 0 Then GoTo 2000

n9 = n9 + 1: GoSub 2750

2000 Next j200

1000 Next j100

End

'   Fill a3()

750 '2   Left

a3(15) = a3(24): a3(16) = a3(25): a3(17) = a3(26): a3(18) = a3(27): a3(19) = a3(28): a3(20) = a3(22): a3(21) = a3(23):
a3(8) = a3(17):  a3(9) = a3(18):  a3(10) = a3(19): a3(11) = a3(20): a3(12) = a3(21): a3(13) = a3(15): a3(14) = a3(16):
a3(1) = a3(10):  a3(2) = a3(11):  a3(3) = a3(12):  a3(4) = a3(13):  a3(5) = a3(14):  a3(6) = a3(8):   a3(7) = a3(9):

a3(29) = a3(27): a3(30) = a3(28): a3(31) = a3(22): a3(32) = a3(23): a3(33) = a3(24): a3(34) = a3(25): a3(35) = a3(26):
a3(36) = a3(34): a3(37) = a3(35): a3(38) = a3(29): a3(39) = a3(30): a3(40) = a3(31): a3(41) = a3(32): a3(42) = a3(33):
a3(43) = a3(41): a3(44) = a3(42): a3(45) = a3(36): a3(46) = a3(37): a3(47) = a3(38): a3(48) = a3(39): a3(49) = a3(40):

Return

780 '3   Left

a3(15) = a3(25): a3(16) = a3(26): a3(17) = a3(27): a3(18) = a3(28): a3(19) = a3(22): a3(20) = a3(23): a3(21) = a3(24):
a3(8) = a3(18):  a3(9) = a3(19):  a3(10) = a3(20): a3(11) = a3(21): a3(12) = a3(15): a3(13) = a3(16): a3(14) = a3(17):
a3(1) = a3(11):  a3(2) = a3(12):  a3(3) = a3(13):  a3(4) = a3(14):  a3(5) = a3(8):   a3(6) = a3(9):   a3(7) = a3(10):

a3(29) = a3(26): a3(30) = a3(27): a3(31) = a3(28): a3(32) = a3(22): a3(33) = a3(23): a3(34) = a3(24): a3(35) = a3(25):
a3(36) = a3(33): a3(37) = a3(34): a3(38) = a3(35): a3(39) = a3(29): a3(40) = a3(30): a3(41) = a3(31): a3(42) = a3(32):
a3(43) = a3(40): a3(44) = a3(41): a3(45) = a3(42): a3(46) = a3(36): a3(47) = a3(37): a3(48) = a3(38): a3(49) = a3(39):

Return

760 '2   Right

a3(15) = a3(27): a3(16) = a3(28): a3(17) = a3(22): a3(18) = a3(23): a3(19) = a3(24): a3(20) = a3(25): a3(21) = a3(26):
a3(8) = a3(20):  a3(9) = a3(21):  a3(10) = a3(15): a3(11) = a3(16): a3(12) = a3(17): a3(13) = a3(18): a3(14) = a3(19):
a3(1) = a3(13):  a3(2) = a3(14):  a3(3) = a3(8):   a3(4) = a3(9):   a3(5) = a3(10):  a3(6) = a3(11):  a3(7) = a3(12):

a3(34) = a3(22): a3(35) = a3(23): a3(29) = a3(24): a3(30) = a3(25): a3(31) = a3(26): a3(32) = a3(27): a3(33) = a3(28):
a3(41) = a3(29): a3(42) = a3(30): a3(36) = a3(31): a3(37) = a3(32): a3(38) = a3(33): a3(39) = a3(34): a3(40) = a3(35):
a3(48) = a3(36): a3(49) = a3(37): a3(43) = a3(38): a3(44) = a3(39): a3(45) = a3(40): a3(46) = a3(41): a3(47) = a3(42):

Return

770 '3   Right

a3(15) = a3(26): a3(16) = a3(27): a3(17) = a3(28): a3(18) = a3(22): a3(19) = a3(23): a3(20) = a3(24): a3(21) = a3(25):
a3(8) = a3(19):  a3(9) = a3(20):  a3(10) = a3(21): a3(11) = a3(15): a3(12) = a3(16): a3(13) = a3(17): a3(14) = a3(18):
a3(1) = a3(12):  a3(2) = a3(13):  a3(3) = a3(14):  a3(4) = a3(8):   a3(5) = a3(9):   a3(6) = a3(10):  a3(7) = a3(11):

a3(33) = a3(22): a3(34) = a3(23): a3(35) = a3(24): a3(29) = a3(25): a3(30) = a3(26): a3(31) = a3(27): a3(32) = a3(28):
a3(40) = a3(29): a3(41) = a3(30): a3(42) = a3(31): a3(36) = a3(32): a3(37) = a3(33): a3(38) = a3(34): a3(39) = a3(35):
a3(47) = a3(36): a3(48) = a3(37): a3(49) = a3(38): a3(43) = a3(39): a3(44) = a3(40): a3(45) = a3(41): a3(46) = a3(42):

Return

'   Determine B2

800  Erase B2

For i1 = 1 To 7
For i2 = 1 To 7
For i0 = 1 To 7
B2(i2 + (i1 - 1) * 7 + (i0 - 1) * 49) = B1(i2 + (i0 - 1) * 7 + (i1 - 1) * 49)
Next i0
Next i2
Next i1

Return

'   Determine B3

850
For i1 = 1 To 7
For i2 = 1 To 7
For i0 = 1 To 7
B3(i1 + (i2 - 1) * 7 + (i0 - 1) * 49) = B1(i1 + (7 - i2) * 7 + (i0 - 1) * 49)
Next i0
Next i2
Next i1
Return

'   Exclude solutions with identical numbers

1300 fl1 = 1
For j10 = 1 To 343
c2 = C(j10): If c2 = 0 Then GoTo 1310
For j20 = (1 + j10) To 343
If c2 = C(j20) Then fl1 = 0: Return
Next j20
1310 Next j10

Return

'    Print Cube (7 Plane Format)

2750 n2 = n2 + 1
If n2 = 2 Then
n2 = 1: k1 = k1 + 56: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 8
End If

Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632: Cells(k1, k2 + 1).Value = n9
Cells(k1, k2 + 2).Font.Color = -4165632: Cells(k1, k2 + 2).Value = j100 - 1 'Hor  Cntr Sqr
Cells(k1, k2 + 3).Font.Color = -4165632: Cells(k1, k2 + 3).Value = j200 - 1 'Vert Cntr Sqr

For i0 = 1 To 7
'        i3 = (7 - i0) * 49
i3 = (i0 - 1) * 49
For i1 = 1 To 7
For i2 = 1 To 7
i3 = i3 + 1
Cells(k1 + i1 + (i0 - 1) * 8, k2 + i2).Value = B1(i3)       'Sudoku B1
Cells(k1 + i1 + (i0 - 1) * 8, k2 + i2 + 8).Value = B2(i3)   'Sudoku B2
Cells(k1 + i1 + (i0 - 1) * 8, k2 + i2 + 16).Value = B3(i3)  'Sudoku B3
Cells(k1 + i1 + (i0 - 1) * 8, k2 + i2 + 24).Value = C(i3)   'Result C
Next i2
Next i1
Next i0

Return

End Sub
```