'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
Sheets("Klad1").Select
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
' reading a2(1,i4): Square 1
n1 = 2: n2 = 2 'start row : column
n4 = 0: i4 = 0 'current square
' reading a2(2,i24): Square 2
n21 = 2: n22 = 2 'start row : column
n24 = 0: i24 = 0 'current square
' reading a2(3,i34): Square 3
n31 = 2: n32 = 2 'start row : column
n34 = 0: i34 = 0 'current square
' reading a2(4,i44): Square 4
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
