About the Author

' Generates Almost Perfect Center Symmetric Sudoku Comparable Cubes of order 5 for integers 0 thru 4

' Tested with Office 2007 under Windows 7

```Sub SudCube5f()

Dim a(125), b(5)

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

n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 4: s1 = 10: s2 = s1 / 5

n4 = 4288                                          'Test5

Sheets("Klad1").Select

t1 = Timer

'    Generate Cubes

For j1 = 1 To n4

Cells(n9 + 1, 126).Select: Cells(n9 + 1, 126).Value = j1

j10 = j1: j20 = 100: GoSub 100                 'Read Sudoku Comparable Square 1

a(63) = s2
For j100 = m1 To m2
a(100) = j100

Cells(n9 + 1, 100).Select: Cells(n9 + 1, 100).Value = j100
Cells(n9 + 1, 101).Value = j1
For j99 = m1 To m2
a(99) = j99

For j98 = m1 To m2
a(98) = j98

For j97 = m1 To m2
a(97) = j97

a(96) = s1 - a(97) - a(98) - a(99) - a(100): If a(96) < m1 Or a(96) > m2 Then GoTo 970

For j95 = m1 To m2
a(95) = j95

For j94 = m1 To m2
a(94) = j94

For j93 = m1 To m2
a(93) = j93

For j92 = m1 To m2
a(92) = j92

a(91) = s1 - a(92) - a(93) - a(94) - a(95): If a(91) < m1 Or a(91) > m2 Then GoTo 920

For j90 = m1 To m2
a(90) = j90

For j89 = m1 To m2
a(89) = j89

a(88) = a(89) - 2*a(93) + 2*a(94) - 2*a(98) + 2*a(99) - a(113) + a(115) - 2*a(118) + 2*a(120) - 2*a(123) + 2*a(125)
If a(88) < m1 Or a(88) > m2 Then GoTo 890
a(87) = (5*s1 - a(88) - 2*a(89) - 4*a(90) + a(93) - 4*a(94) - 2*a(95) - 2*a(97) - 4*a(99) - 4*a(100) - 3*a(112) +
+ a(114) - 3*a(115) - 2*a(117) + 2*a(118) + 2*a(119) - 2*a(120) + 3*a(123) + 2*a(124)) / 3

If a(87) < m1 Or a(87) > m2 Or CInt(a(87)) <> a(87) Then GoTo 890
a(86) = s1 - a(87) - a(88) - a(89) - a(90): If a(86) < m1 Or a(86) > m2 Then GoTo 890
a(85) = (-4*s1 + 6*a(89)  - a(90) + 3*a(92) - 9*a(93) + 9*a(94) - 3*a(95) - 3*a(97) - 11*a(98) + 5*a(99) - 6*a(100) +
+ 2*a(108) + 3*a(110) - 4*a(113) + 4*a(114) + 10*a(115) - 2*a(117) - 8*a(118) + 2*a(119) + 13*a(120) +
+ 2*a(122) - 5*a(123) + 4*a(124) + 14*a(125)) / 5

If a(85) < m1 Or a(85) > m2 Or CInt(a(85)) <> a(85) Then GoTo 890
a(84) = -s1 + a(85) - a(89) + a(90) - a(92) + 2*a(93) - 2*a(94) + a(95) + a(97) + 3*a(98) - a(99) + 2*a(100) +
+ a(113) - a(115) + 2*a(118) - 2*a(120) + 2*a(123) - 2*a(125)

If a(84) < m1 Or a(84) > m2 Then GoTo 890
a(83) = a(84) + a(93) - a(94) - a(108) + a(110) + a(118) - a(120)

If a(83) < m1 Or a(83) > m2 Then GoTo 890
a(82) = (7*s1 + 2*a(84) + 2*a(87) - 2*a(89) - a(108) - 4*a(110) + 3*a(112) + a(113) - 5*a(114) - 4*a(115) + 4*a(117) +
- a(118) - 4*a(119) - 4*a(120) - 2*a(122) - 4*a(123) - 6*a(124) - 8*a(125)) / 2

If a(82) < m1 Or a(82) > m2 Or CInt(a(82)) <> a(82) Then GoTo 890
a(81) = s1 - a(82) - a(83) - a(84) - a(85): If a(81) < m1 Or a(81) > m2 Then GoTo 890
a(80) = s1 - a(84) - a(88) - a(92) - a(96): If a(80) < m1 Or a(80) > m2 Then GoTo 890
a(79) = s1 - a(84) - a(89) - a(94) - a(99): If a(79) < m1 Or a(79) > m2 Then GoTo 890
a(78) = s1 - a(83) - a(88) - a(93) - a(98): If a(78) < m1 Or a(78) > m2 Then GoTo 890
a(77) = s1 - a(82) - a(87) - a(92) - a(97): If a(77) < m1 Or a(77) > m2 Then GoTo 890
a(76) = s1 - a(77) - a(78) - a(79) - a(80): If a(76) < m1 Or a(76) > m2 Then GoTo 890

a(75) = (-13*s2 + 2*a(76) - 2*a(100) + a(108) + 2*a(110) + a(112) - a(113) + a(114) + 2*a(115) + a(118) + 2*a(120) +
+ 2*a(122) + 2*a(123) + 2*a(124)) / 2

If a(75) < m1 Or a(75) > m2 Or CInt(a(75)) <> a(75) Then GoTo 890
a(74) = (-3*s2 + 2*a(77) - 2*a(99) + a(108) + 2*a(110) - a(112) + a(113) + a(114) + 2*a(115) - 2*a(116) - 4*a(117) +
- a(118) + 2*a(123) + 4*a(125)) / 2
If a(74) < m1 Or a(74) > m2 Or CInt(a(74)) <> a(74) Then GoTo 890
a(73) = 6*s2 + a(78) - a(98) - a(108) - a(113) - a(118) - 2*a(123)
If a(73) < m1 Or a(73) > m2 Then GoTo 890
a(72) = s1 + a(73) - a(97) + a(99) + a(113) - a(114) + a(117) - a(119) - 2*a(122) - a(123) - 2*a(124)
If a(72) < m1 Or a(72) > m2 Then GoTo 890
a(71) = s1 - a(72) - a(73) - a(74) - a(75): If a(71) < m1 Or a(71) > m2 Then GoTo 890
a(70) = (-3*s2+2*a(81)-2*a(95)-a(108)-2*a(110)+a(112)+3*a(113)+a(114)+2*a(117)+a(118)+2*a(119)-2*a(120)) / 2

If a(70) < m1 Or a(70) > m2 Or CInt(a(70)) <> a(70) Then GoTo 890
a(69)= (12*s2+2*a(82)-2*a(94)-a(108)-2*a(110)+a(111)-a(115)-a(118)-4*a(119)-2*a(120)+2*a(121)-2*a(125)) / 2

If a(69) < m1 Or a(69) > m2 Or CInt(a(69)) <> a(69) Then GoTo 890
a(68) = s2 + a(83) - a(93) + a(108) - a(118): If a(68) < m1 Or a(68) > m2 Then GoTo 890
a(67) = s2 + a(84) - a(92) + a(110) - a(113) + a(115) - 2*a(117) + a(120) - a(121) + a(125)
If a(67) < m1 Or a(67) > m2 Then GoTo 890
a(66) = s1 - a(67) - a(68) - a(69) - a(70): If a(66) < m1 Or a(66) > m2 Then GoTo 890
a(65) = 11*s2 - a(87) - 2*a(89) - 2*a(90) + 2*a(93) - 2*a(94) + 2*a(98) - 2*a(99) - a(112) - a(114) - 3*a(115) +
+ 2*a(118) - 2*a(120) + 2*a(123) - 2*a(125)

If a(65) < m1 Or a(65) > m2 Then GoTo 890
a(64) = s2 + a(87) - a(89) + a(112) - a(114): If a(64) < m1 Or a(64) > m2 Then GoTo 890

a(1)  = 2*s2 - a(125): a(2)  = 2*s2 - a(124): a(3)  = 2*s2 - a(123): a(4)  = 2*s2 - a(122): a(5)  = 2*s2 - a(121):
a(6)  = 2*s2 - a(120): a(7)  = 2*s2 - a(119): a(8)  = 2*s2 - a(118): a(9)  = 2*s2 - a(117): a(10) = 2*s2 - a(116):
a(11) = 2*s2 - a(115): a(12) = 2*s2 - a(114): a(13) = 2*s2 - a(113): a(14) = 2*s2 - a(112): a(15) = 2*s2 - a(111):
a(16) = 2*s2 - a(110): a(17) = 2*s2 - a(109): a(18) = 2*s2 - a(108): a(19) = 2*s2 - a(107): a(20) = 2*s2 - a(106):
a(21) = 2*s2 - a(105): a(22) = 2*s2 - a(104): a(23) = 2*s2 - a(103): a(24) = 2*s2 - a(102): a(25) = 2*s2 - a(101):
a(26) = 2*s2 - a(100): a(27) = 2*s2 - a(99):  a(28) = 2*s2 - a(98):  a(29) = 2*s2 - a(97):  a(30) = 2*s2 - a(96):
a(31) = 2*s2 - a(95):  a(32) = 2*s2 - a(94):  a(33) = 2*s2 - a(93):  a(34) = 2*s2 - a(92):  a(35) = 2*s2 - a(91):
a(36) = 2*s2 - a(90):  a(37) = 2*s2 - a(89):  a(38) = 2*s2 - a(88):  a(39) = 2*s2 - a(87):  a(40) = 2*s2 - a(86):
a(41) = 2*s2 - a(85):  a(42) = 2*s2 - a(84):  a(43) = 2*s2 - a(83):  a(44) = 2*s2 - a(82):  a(45) = 2*s2 - a(81):
a(46) = 2*s2 - a(80):  a(47) = 2*s2 - a(79):  a(48) = 2*s2 - a(78):  a(49) = 2*s2 - a(77):  a(50) = 2*s2 - a(76):
a(51) = 2*s2 - a(75):  a(52) = 2*s2 - a(74):  a(53) = 2*s2 - a(73):  a(54) = 2*s2 - a(72):  a(55) = 2*s2 - a(71):
a(56) = 2*s2 - a(70):  a(57) = 2*s2 - a(69):  a(58) = 2*s2 - a(68):  a(59) = 2*s2 - a(67):  a(60) = 2*s2 - a(66):
a(61) = 2*s2 - a(65):  a(62) = 2*s2 - a(64):

'   Exclude solutions with identical numbers in rows, colums, pillars

GoSub 800: If fl1 = 0 Then GoTo 890

n9 = n9 + 1

GoSub 1740 'Print results (selected numbers)
'   GoSub 1750 'Print results (planes 11, 12, 13, 14 and 15)

890 Next j89
900 Next j90

920 Next j92
930 Next j93
940 Next j94
950 Next j95

970 Next j97
980 Next j98
990 Next j99
1000 Next j100

Next j1

t2 = Timer

t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
y = MsgBox(t10, 0, "Routine SudCube5f")

End

'   Read Sudoku Comparable Squares (line format)

100
For i1 = 1 To 25
a(j20 + i1) = Sheets("Test5").Cells(j10, i1).Value
Next i1
Return

'   Exclude solutions with identical numbers in rows, colums and pillars

800 fl1 = 1

'   Rows

i1 = -4
For i0 = 1 To 25
i1 = i1 + 5
b(1) = a(i1): b(2) = a(i1 + 1): b(3) = a(i1 + 2): b(4) = a(i1 + 3): b(5) = a(i1 + 4)
GoSub 860
If fl1 = 0 Then Return
Next i0

'   Columns

i1 = 0: i2 = 0
For i0 = 1 To 25
i1 = i1 + 1
b(1) = a(i1): b(2) = a(i1 + 5): b(3) = a(i1 + 10): b(4) = a(i1 + 15): b(5) = a(i1 + 20)
i2 = i2 + 1: If i2 = 5 Then i2 = 0: i1 = i1 + 20
GoSub 860
If fl1 = 0 Then Return
Next i0

'   Pillars

i1 = 0: i2 = 0
For i0 = 1 To 25
i1 = i0
b(1) = a(i1): b(2) = a(i1 + 25): b(3) = a(i1 + 50): b(4) = a(i1 + 75): b(5) = a(i1 + 100)
GoSub 860
If fl1 = 0 Then Return
Next i0

Return

860 fl1 = 1
For j3 = 1 To 5
b2 = b(j3)
For j4 = (1 + j3) To 5
If b2 = b(j4) Then fl1 = 0: Return
Next j4
Next j3
Return

'    Print results (selected numbers)

1740 For i1 = 1 To 125
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 100).Select
Return

'    Print results (planes 11, 12, 13, 14 and 15)

1750 n2 = n2 + 1
If n2 = 7 Then
n2 = 1: k1 = k1 + 30: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 6
End If

For i0 = 1 To 5
i3 = (5 - i0) * 25
For i1 = 1 To 5
For i2 = 1 To 5
i3 = i3 + 1
Cells(k1 + i1 + (i0 - 1) * 6, k2 + i2).Value = a(i3)
Next i2
Next i1
If i0 = 1 Then
Cells(k1 + (i0 - 1) * 6, k2 + 1).Value = "Plane 1" + CStr(i0) + ", C" + CStr(n9)
Else
Cells(k1 + (i0 - 1) * 6, k2 + 1).Value = "Plane 1" + CStr(i0)
End If
Next i0

Return

End Sub
```

 About the Author