 About the Author

'Collects the second, third and fourth 5 x 5 square (all elements different) based on the first
'The fifth square is calculated

' Tested with Office 2007 under Windows 7

```Sub SudCube5b()

Dim a1(125), a2(5, 25), a3(25), s3(4), s2(3, 10), b(5)
Dim txt1 As String, txt2 As String, t1 As String

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

Sht1 = "SudSqrs5"                                       'input sheet

n3 = 4288                                               'number of squares to be checked, 240 Pan Magic Sudoku51
'                                 960 Magic     Sudoku52
'                                4288 Magic     SudSqr5
k1 = 1: k2 = 1: n20 = 0                                 'Print parameters

t1 = Timer

n1 = 2: n2 = 2                                      'start row : column
n4 = 0: i4 = 0                                      'current square

n21 = 2: n22 = 2                                    'start row : column
n24 = 0: i24 = 0                                    'current square

n31 = 2: n32 = 2                                    'start row : column
n34 = 0: i34 = 0                                    'current square

n41 = 2: n42 = 2                                    'start row : column
n44 = 0: i44 = 0                                    'current square

Cells(n9 + 1, 125).Select
For j3 = 1 To n3                                        'Square nr j3 current
n4 = n4 + 1: n2 = 2 + (n4 - 1) * 6: i4 = 0
Cells(n9 + 1, 127).Value = j3

For j1 = n1 To n1 + 4                               'Row    within square j3
For j2 = n2 To n2 + 4                           'Column within square j3
i4 = i4 + 1
a2(1, i4) = Sheets(Sht1).Cells(j1, j2).Value          'load square 1
Next j2
Next j1
If a2(1, 13) = 2 Then GoTo 10                        'Only a2(3, 13) = 2 for Spacediagonals

If n4 < 4 Then
n24 = n4: n21 = n1
Else
n24 = 0: n21 = n1 + 6
End If

For j23 = 1 To n3                                   'Square nr j23 to be checked
n24 = n24 + 1: n22 = 2 + (n24 - 1) * 6: i24 = 0
SqrNr2 = Sheets(Sht1).Cells(n21 - 1, n22).Value
Cells(n9 + 1, 128).Value = SqrNr2
If SqrNr2 = 0 Then GoTo 10                      'End of range

For j21 = n21 To n21 + 4                        'Row    within square j23
For j22 = n22 To n22 + 4                    'Column within square j23
i24 = i24 + 1
a2(2, i24) = Sheets(Sht1).Cells(j21, j22).Value    'load square 2
Next j22
Next j21
If a2(2, 13) = 2 Then GoTo 20                   'Only a2(3, 13) = 2 for Spacediagonals

GoSub 100                                       'Check all elements Square 2 and 1
If fl1 = 0 Then

If n24 < 4 Then
n34 = n24: n31 = n21
Else
n34 = 0: n31 = n21 + 6
End If

For j33 = 1 To n3                                    'Square nr j33 to be checked
n34 = n34 + 1: n32 = 2 + (n34 - 1) * 6: i34 = 0
SqrNr3 = Sheets(Sht1).Cells(n31 - 1, n32).Value
Cells(n9 + 1, 129).Value = SqrNr3
If SqrNr3 = 0 Then GoTo 20                       'End of range

For j31 = n31 To n31 + 4                         'Row    within square j33
For j32 = n32 To n32 + 4                     'Column within square j33
i34 = i34 + 1
a2(3, i34) = Sheets(Sht1).Cells(j31, j32).Value        'load square 3
Next j32
Next j31
If a2(3, 13) <> 2 Then GoTo 30                   'a2(3, 13) = 2 for Spacediagonals

GoSub 200                                        'Check all elements Square 3 and 1,2
If fl2 = 0 Then

If n34 < 4 Then
n44 = n34: n41 = n31
Else
n44 = 0: n41 = n31 + 6
End If

For j43 = 1 To n3                                   'Square nr j43 to be checked
n44 = n44 + 1: n42 = 2 + (n44 - 1) * 6: i44 = 0
SqrNr4 = Sheets(Sht1).Cells(n41 - 1, n42).Value
Cells(n9 + 1, 130).Value = SqrNr4
If SqrNr4 = 0 Then GoTo 30                      'End of range

For j41 = n41 To n41 + 4                        'Row    within square j43
For j42 = n42 To n42 + 4                    'Column within square j43
i44 = i44 + 1
a2(4, i44) = Sheets(Sht1).Cells(j41, j42).Value      'load square 4
Next j42
Next j41

GoSub 300                                       'Check all elements Square 4 and 1,2,3
If fl3 = 0 Then

For j10 = 1 To 25                            'Complete Cube
a2(5, j10) = 10 - a2(1, j10) - a2(2, j10) - a2(3, j10) - a2(4, j10)
Next j10

For j20 = 1 To 5
For j10 = 1 To 25
a1((5 - j20) * 25 + j10) = a2(j20, j10)
Next j10
Next j20

n9 = n9 + 1: GoSub 500                      'Print Cube (selected numbers)
''                 n9 = n9 + 1: GoSub 600                      'Print Cube (5 plane view)

End If
40              If n44 = 4 Then n44 = 0: n41 = n41 + 6: n42 = 2
Next j43

End If
30      If n34 = 4 Then n34 = 0: n31 = n31 + 6: n32 = 2
Next j33

End If
20  If n24 = 4 Then n24 = 0: n21 = n21 + 6: n22 = 2
Next j23

10  If n4 = 4 Then n4 = 0: n1 = n1 + 6: n2 = 2
Next j3

t2 = Timer

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

End

'   Check all elements Square 1 differ from all elements of Square 2

100 fl1 = 1
For j10 = 1 To 25: a3(j10) = 0: Next j10
For j10 = 1 To 25
If a2(2, j10) = a2(1, j10) Then a3(j10) = 1
Next j10
n10 = 0
For j10 = 1 To 25
If a3(j10) = 0 Then n10 = n10 + 1              'count unequal element
Next j10
If n10 = 25 Then fl1 = 0

Return

'   Check all elements Square 3 differ from all elements of Square 2 and 1

200 fl2 = 1
For j10 = 1 To 25: a3(j10) = 0: Next j10
For j10 = 1 To 25
If a2(3, j10) = a2(1, j10) Then a3(j10) = 1
If a2(3, j10) = a2(2, j10) Then a3(j10) = 1
Next j10
n10 = 0
For j10 = 1 To 25
If a3(j10) = 0 Then n10 = n10 + 1              'count unequal element
Next j10
If n10 = 25 Then fl2 = 0

Return

'   Check all elements Square 4 differ from all elements of Square 3, 2 and 1

300 fl3 = 1
For j10 = 1 To 25: a3(j10) = 0: Next j10
For j10 = 1 To 25
If a2(4, j10) = a2(1, j10) Then a3(j10) = 1
If a2(4, j10) = a2(2, j10) Then a3(j10) = 1
If a2(4, j10) = a2(3, j10) Then a3(j10) = 1
Next j10
n10 = 0
For j10 = 1 To 25
If a3(j10) = 0 Then n10 = n10 + 1               'count unequal element
Next j10
If n10 = 25 Then fl3 = 0
Return

'   Print results (selected numbers)

500 Cells(n9, 125).Select
For i1 = 1 To 125
Cells(n9, i1).Value = a1(i1)
Next i1

Return

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

600 n20 = n20 + 1
If n20 = 7 Then
n20 = 1: k1 = k1 + 30: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 6
End If

Cells(k1, k2).Select: y = MsgBox("Test", 0, "Test")
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 = a1(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