' Generates Sudoku Comparable Squares of order 5 for integers 0 thru 4 (Sudoku Diagonals)
' This Macro is based on the devellopment of SudCube5
' Tested with Office 2007 under Windows 7
Sub SudSqr5a()
Dim a(125), a5(25), s(12)
y = MsgBox("Locked", vbCritical, "Routine SudSqr5a")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
s1 = 10
m1 = 0: m2 = 4
Sheets("Klad1").Select
t1 = Timer
' Generate Squares
For j125 = m1 To m2
a(125) = j125
For j124 = m1 To m2
If j124 = j125 Then GoTo 1240 'Check Row
a(124) = j124
For j123 = m1 To m2
If j123 = j124 Or j123 = j125 Then GoTo 1230 'Check Row
a(123) = j123
For j122 = m1 To m2
If j122 = j123 Or j122 = j124 Or j122 = j125 Then GoTo 1220 'Check Row
a(122) = j122
a(121) = s1 - a(122) - a(123) - a(124) - a(125): j121 = a(121)
For j120 = m1 To m2
If j120 = j125 Then GoTo 1200 'Check Colum
a(120) = j120
For j119 = m1 To m2
If j119 = j120 Then GoTo 1190 'Check Row
If j119 = j124 Or j119 = j125 Then GoTo 1190 'Check Column and Diagonal
a(119) = j119
For j118 = m1 To m2
If j118 = j119 Or j118 = j120 Then GoTo 1180 'Check Row
If j118 = j123 Then GoTo 1180 'Check Column
a(118) = j118
For j117 = m1 To m2
If j117 = j118 Or j117 = j119 Or j117 = j120 Then GoTo 1170 'Check Row
If j117 = j121 Or j117 = j122 Then GoTo 1170 'Check Column and Diagonal
a(117) = j117
a(116) = s1 - a(117) - a(118) - a(119) - a(120): j116 = a(116)
If j116 = j121 Then GoTo 1170 'Check Column
For j115 = m1 To m2
If j115 = j120 Or j115 = j125 Then GoTo 1150 'Check Column
a(115) = j115
For j114 = m1 To m2
If j114 = j115 Then GoTo 1140 'Check Row
If j114 = j119 Or j114 = j124 Then GoTo 1140 'Check Column
a(114) = j114
For j113 = m1 To m2
If j113 = j114 Or j113 = j115 Then GoTo 1130 'Check Row
If j113 = j118 Or j113 = j123 Then GoTo 1130 'Check Column
If j113 = j119 Or j113 = j125 Or j113 = j117 Or j113 = j121 Then GoTo 1130 'Check Diagonals
a(113) = j113
For j112 = m1 To m2
If j112 = j113 Or j112 = j114 Or j112 = j115 Then GoTo 1120 'Check Row
If j112 = j117 Or j112 = j122 Then GoTo 1120 'Check Column
a(112) = j112
a(111) = s1 - a(112) - a(113) - a(114) - a(115): j111 = a(111)
If j111 = j116 Or j111 = j121 Then GoTo 1120 'Check Column
For j110 = m1 To m2
If j110 = j115 Or j110 = j120 Or j110 = j125 Then GoTo 1100 'Check Column
a(110) = j110
a(109) = a(110) - a(113) + a(115) - a(117) + a(120) - a(121) + a(125): j109 = a(109)
If a(109) < m1 Or a(109) > m2 Then GoTo 1100
If j109 = j110 Then GoTo 1100 'Check Row
If j109 = j114 Or j109 = j119 Or j109 = j124 Then GoTo 1100 'Check Column
If j109 = j113 Or j109 = j117 Or j109 = j121 Then GoTo 1100 'Check Diagonal
For j108 = m1 To m2
If j108 = j109 Or j108 = j110 Then GoTo 1080 'Check Row
If j108 = j113 Or j108 = j118 Or j108 = j123 Then GoTo 1080 'Check Column
a(108) = j108
a(107) = (s1 - a(108) - a(109) - a(110) + a(111) - a(113) + a(116) - a(119) + a(121) - a(125)) / 2
j107 = Int(a(107)): If j107 <> a(107) Then GoTo 1080
If a(107) < m1 Or a(107) > m2 Then GoTo 1080
If j107 = j108 Or j107 = j109 Or j107 = j110 Then GoTo 1080 'Check Row
If j107 = j112 Or j107 = j117 Or j107 = j122 Then GoTo 1080 'Check Column
If j107 = j113 Or j107 = j119 Or j107 = j125 Then GoTo 1080 'Check Diagonal
a(106) = s1 - a(107) - a(108) - a(109) - a(110): If a(106) < m1 Or a(106) > m2 Then GoTo 1080
j106 = a(106)
If j106 = j111 Or j106 = j116 Or j106 = j121 Then GoTo 1080 'Check Column
a(105) = s1 - a(109) - a(113) - a(117) - a(121): If a(105) < m1 Or a(105) > m2 Then GoTo 1080
a(104) = s1 - a(109) - a(114) - a(119) - a(124): If a(104) < m1 Or a(104) > m2 Then GoTo 1080
a(103) = s1 - a(108) - a(113) - a(118) - a(123): If a(103) < m1 Or a(103) > m2 Then GoTo 1080
a(102) = s1 - a(107) - a(112) - a(117) - a(122): If a(102) < m1 Or a(102) > m2 Then GoTo 1080
a(101) = s1 - a(102) - a(103) - a(104) - a(105): If a(101) < m1 Or a(101) > m2 Then GoTo 1080
GoSub 800: If fl1 = 0 Then GoTo 1080 'Check last row
' GoSub 900: If fl1 = 0 Then GoTo 1080 'Check Pan Diagonals
' GoSub 950: If fl1 = 0 Then GoTo 1080 'Check Associated
n9 = n9 + 1
GoSub 1740 'Print results (selected numbers)
' GoSub 1750 'Print results (Squares)
1080 Next j108
1100 Next j110
1120 Next j112
1130 Next j113
1140 Next j114
1150 Next j115
1170 Next j117
1180 Next j118
1190 Next j119
1200 Next j120
1220 Next j122
1230 Next j123
1240 Next j124
1250 Next j125
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
y = MsgBox(t10, 0, "Routine SudSqr5a")
End
' Check last row
800 fl1 = 1
For j1 = 101 To 105
a2 = a(j1)
For j2 = (1 + j1) To 105
If a2 = a(j2) Then fl1 = 0: GoTo 850
Next j2
Next j1
850 Return
' Check Pan Diagonal
900 fl1 = 1
For i1 = 1 To 25
a5(i1) = a(100 + i1)
Next i1
' Pan Diagonals
s(1) = a5(2) + a5(8) + a5(14) + a5(20) + a5(21)
s(2) = a5(3) + a5(9) + a5(15) + a5(16) + a5(22)
s(3) = a5(4) + a5(10) + a5(11) + a5(17) + a5(23)
s(4) = a5(5) + a5(6) + a5(12) + a5(18) + a5(24)
s(5) = a5(4) + a5(8) + a5(12) + a5(16) + a5(25)
s(6) = a5(3) + a5(7) + a5(11) + a5(20) + a5(24)
s(7) = a5(2) + a5(6) + a5(15) + a5(19) + a5(23)
s(8) = a5(1) + a5(10) + a5(14) + a5(18) + a5(22)
For i1 = 1 To 8
If s(i1) <> s1 Then fl1 = 0: n10 = n10 + 1: Return
Next i1
Return
' Check Associated
950 fl1 = 1: s2 = 4
For i1 = 1 To 25
a5(i1) = a(100 + i1)
Next i1
' Associated Pairs
s(1) = a5(1) + a5(25): s(2) = a5(2) + a5(24): s(3) = a5(3) + a5(23): s(4) = a5(4) + a5(22):
s(5) = a5(5) + a5(21): s(6) = a5(6) + a5(20): s(7) = a5(7) + a5(19): s(8) = a5(8) + a5(18):
s(9) = a5(9) + a5(17): s(10) = a5(10) + a5(16): s(11) = a5(11) + a5(15): s(12) = a5(12) + a5(14):
For i1 = 1 To 12
If s(i1) <> s2 Then fl1 = 0: n10 = n10 + 1: Return
Next i1
Return
' Print results (selected numbers)
1740 Cells(n9, 25).Select
For i1 = 101 To 125
Cells(n9, i1 - 100).Value = a(i1)
Next i1
Return
' Print results (squares)
1750 For i1 = 1 To 25
a5(i1) = a(100 + i1)
Next i1
n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 6: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 6
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 5
For i2 = 1 To 5
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a5(i3)
Next i2
Next i1
Return
End Sub
