' Generates Sudoku Comparable Ultra Magic Squares of order 7 for integers 0 thru 6
' Tested with Office 2007 under Windows 7
Sub SudSqr7b()
Dim a(49), b(7)
y = MsgBox("Locked", vbCritical, "Routine SudSqr7b")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 6: s1 = 21: s2 = 2 * s1 / 7
' Generate squares
Sheets("Klad1").Select
t1 = Timer
a(25) = s1 / 7
For j49 = m1 To m2
a(49) = j49
For j48 = m1 To m2
If j48 = j49 Then GoTo 480
a(48) = j48
For j47 = m1 To m2
If j47 = j48 Or j47 = j49 Then GoTo 470
a(47) = j47
For j46 = m1 To m2
If j46 = j47 Or j46 = j48 Or j46 = j49 Then GoTo 460
a(46) = j46
For j45 = m1 To m2
If j45 = j46 Or j45 = j47 Or j45 = j48 Or j45 = j49 Then GoTo 450
a(45) = j45
For j44 = m1 To m2
If j44 = j45 Or j44 = j46 Or j44 = j47 Or j44 = j48 Or j44 = j49 Then GoTo 440
a(44) = j44
a(43) = s1 - a(44) - a(45) - a(46) - a(47) - a(48) - a(49)
If a(43) < m1 Or a(43) > m2 Then GoTo 440
For j42 = m1 To m2
If j42 = j49 Then GoTo 420
a(42) = j42
For j41 = m1 To m2
If j41 = j42 Then GoTo 410
If j41 = j48 Then GoTo 410
a(41) = j41
a(35) = 6 * s1 / 7 - a(41) - a(42) - a(47) - a(48) - a(49)
If a(35) < m1 Or a(35) > m2 Then GoTo 410
For j40 = m1 To m2
If j40 = j41 Or j40 = j42 Then GoTo 400
If j40 = j47 Then GoTo 400
a(40) = j40
For j39 = m1 To m2
If j39 = j40 Or j39 = j41 Or j39 = j42 Then GoTo 390
If j39 = j46 Then GoTo 390
a(39) = j39
a(30) = -8 * s1 / 7 + a(39) + a(40) + 2 * a(41) + a(42) - a(44) + 2 * a(47) + 2 * a(48) + a(49)
If a(30) < m1 Or a(30) > m2 Then GoTo 390
a(27) = -13 * s1 / 7 + a(39) + 2 * a(40) + 2 * a(41) + 2 * a(42) - a(44) - a(45) + a(46) + 3 * a(47) + 3 * a(48) + 2 * a(49)
If a(27) < m1 Or a(27) > m2 Then GoTo 390
For j38 = m1 To m2
If j38 = j39 Or j38 = j40 Or j38 = j41 Or j38 = j42 Then GoTo 380
If j38 = j45 Then GoTo 380
a(38) = j38
a(33) = 6 * s1 / 7 + a(38) - a(39) - a(40) - a(41) + a(44) - 2 * a(47) - a(48) - a(49)
If a(33) < m1 Or a(33) > m2 Then GoTo 380
a(32) = 6 * s1 / 7 - a(38) - a(40) - a(44) - a(46) - a(48)
If a(32) < m1 Or a(32) > m2 Then GoTo 380
a(29) = -8 * s1 / 7 + a(38) + a(39) + a(40) + a(41) + a(42) + a(46) + a(47) + a(48) + a(49)
If a(29) < m1 Or a(29) > m2 Then GoTo 380
For j37 = m1 To m2
If j37 = j38 Or j37 = j39 Or j37 = j40 Or j37 = j41 Or j37 = j42 Then GoTo 370
If j37 = j44 Then GoTo 370
a(37) = j37
a(36) = s1 - a(37) - a(38) - a(39) - a(40) - a(41) - a(42)
If a(36) < m1 Or a(36) > m2 Then GoTo 370
a(34) = a(35) + a(37) - a(40) + a(44) + a(45) - a(46) - a(48)
If a(34) < m1 Or a(34) > m2 Then GoTo 370
a(31) = 12 * s1 / 7 - a(33) - a(37) - 2 * a(39) - a(41) - a(43) - 2 * a(45) - 2 * a(47) - a(49)
If a(31) < m1 Or a(31) > m2 Then GoTo 370
a(28) = s1 / 7 - a(37) + a(41) - a(44) - a(45) + a(47) + a(48)
If a(28) < m1 Or a(28) > m2 Then GoTo 370
a(26) = a(27) + a(36) - a(42) + a(45) - a(47)
If a(26) < m1 Or a(26) > m2 Then GoTo 370
a(24) = s2 - a(26): a(23) = s2 - a(27): a(22) = s2 - a(28): a(21) = s2 - a(29):
a(20) = s2 - a(30): a(19) = s2 - a(31): a(18) = s2 - a(32): a(17) = s2 - a(33):
a(16) = s2 - a(34): a(15) = s2 - a(35): a(14) = s2 - a(36): a(13) = s2 - a(37):
a(12) = s2 - a(38): a(11) = s2 - a(39): a(10) = s2 - a(40): a(9) = s2 - a(41):
a(8) = s2 - a(42): a(7) = s2 - a(43): a(6) = s2 - a(44): a(5) = s2 - a(45):
a(4) = s2 - a(46): a(3) = s2 - a(47): a(2) = s2 - a(48): a(1) = s2 - a(49):
' Exclude solutions with identical numbers in rows, columns, diagonals
GoSub 800: If fl1 = 0 Then GoTo 370
n9 = n9 + 1: GoSub 645 'Print results (selected numbers)
'' n9 = n9 + 1: GoSub 650 'Print results (squares)
370 Next j37
380 Next j38
390 Next j39
400 Next j40
410 Next j41
420 Next j42
440 Next j44
450 Next j45
460 Next j46
470 Next j47
480 Next j48
490 Next j49
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine SudSqr7b")
End
' Print results (selected numbers)
645 For i1 = 1 To 49
Cells(n9, i1).Value = a(i1)
Next i1
Return
' Print results (squares)
650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 8: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 8
End If
Cells(k1 + 1, k2 + 1).Select
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 7
For i2 = 1 To 7
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
' Exclude solutions with identical numbers in rows, columns, diagonals
800 fl1 = 1
' Rows
i1 = -6
For i0 = 1 To 7
i1 = i1 + 7
b(1) = a(i1): b(2) = a(i1 + 1): b(3) = a(i1 + 2): b(4) = a(i1 + 3): b(5) = a(i1 + 4): b(6) = a(i1 + 5): b(7) = a(i1 + 6)
GoSub 860: If fl1 = 0 Then Return
Next i0
' Columns
i1 = 0
For i0 = 1 To 7
i1 = i1 + 1
b(1) = a(i1): b(2) = a(i1 + 7): b(3) = a(i1 + 14): b(4) = a(i1 + 21): b(5) = a(i1 + 28): b(6) = a(i1 + 35): b(7) = a(i1 + 42)
GoSub 860: If fl1 = 0 Then Return
Next i0
' (Pan) Diagonals
b(1) = a(1): b(2) = a(9): b(3) = a(17): b(4) = a(25): b(5) = a(33): b(6) = a(41): b(7) = a(49): GoSub 860: If fl1 = 0 Then Return
b(1) = a(2): b(2) = a(10): b(3) = a(18): b(4) = a(26): b(5) = a(34): b(6) = a(42): b(7) = a(43): GoSub 860: If fl1 = 0 Then Return
b(1) = a(3): b(2) = a(11): b(3) = a(19): b(4) = a(27): b(5) = a(35): b(6) = a(36): b(7) = a(44): GoSub 860: If fl1 = 0 Then Return
b(1) = a(4): b(2) = a(12): b(3) = a(20): b(4) = a(28): b(5) = a(29): b(6) = a(37): b(7) = a(45): GoSub 860: If fl1 = 0 Then Return
b(1) = a(5): b(2) = a(13): b(3) = a(21): b(4) = a(22): b(5) = a(30): b(6) = a(38): b(7) = a(46): GoSub 860: If fl1 = 0 Then Return
b(1) = a(6): b(2) = a(14): b(3) = a(15): b(4) = a(23): b(5) = a(31): b(6) = a(39): b(7) = a(47): GoSub 860: If fl1 = 0 Then Return
b(1) = a(7): b(2) = a(8): b(3) = a(16): b(4) = a(24): b(5) = a(32): b(6) = a(40): b(7) = a(48): GoSub 860: If fl1 = 0 Then Return
b(1) = a(43): b(2) = a(37): b(3) = a(31): b(4) = a(25): b(5) = a(19): b(6) = a(13): b(7) = a(7): GoSub 860: If fl1 = 0 Then Return
b(1) = a(44): b(2) = a(38): b(3) = a(32): b(4) = a(26): b(5) = a(20): b(6) = a(14): b(7) = a(1): GoSub 860: If fl1 = 0 Then Return
b(1) = a(45): b(2) = a(39): b(3) = a(33): b(4) = a(27): b(5) = a(21): b(6) = a(8): b(7) = a(2): GoSub 860: If fl1 = 0 Then Return
b(1) = a(46): b(2) = a(40): b(3) = a(34): b(4) = a(28): b(5) = a(15): b(6) = a(9): b(7) = a(3): GoSub 860: If fl1 = 0 Then Return
b(1) = a(47): b(2) = a(41): b(3) = a(35): b(4) = a(22): b(5) = a(16): b(6) = a(10): b(7) = a(4): GoSub 860: If fl1 = 0 Then Return
b(1) = a(48): b(2) = a(42): b(3) = a(29): b(4) = a(23): b(5) = a(17): b(6) = a(11): b(7) = a(5): GoSub 860: If fl1 = 0 Then Return
b(1) = a(49): b(2) = a(36): b(3) = a(30): b(4) = a(24): b(5) = a(18): b(6) = a(12): b(7) = a(6): GoSub 860: If fl1 = 0 Then Return
Return
860 fl1 = 1
For j1 = 1 To 7
b2 = b(j1)
For j2 = (1 + j1) To 7
If b2 = b(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
End Sub
