' 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
Sheets("Klad1").Select
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
