' Generates Sudoku Comparable Squares of order 5 for integers 0 thru 4 (Non Sudoku Diagonals)
' This Macro is based on the devellopment of SudCube5
' Tested with Office 2007 under Windows 7
Sub SudSqr5b()
Dim a(125), a5(25), s(10)
y = MsgBox("Locked", vbCritical, "Routine SudSqr5b")
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 Then GoTo 1190 'Check Colum
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 = j122 Then GoTo 1170 'Check Colum
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
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
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
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
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 SudSqr5b")
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
' 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
