' Generates Sudoku Comparable Pan Magic Squares of order 7 for integers 0 thru 6
' Tested with Office 2007 under Windows 7
Sub SudSqr7a()
Dim a(49)
y = MsgBox("Locked", vbCritical, "Routine SudSqr7a")
End
k1 = 1: k2 = 1: n2 = 0: n9 = 0
Sheets("Klad1").Select
t1 = Timer
For j1 = 1 To 6
For j2 = 1 To 6
If j2 = j1 Then GoTo 20
For j3 = 1 To 6
If j3 = j2 Or j3 = j1 Then GoTo 30
For j4 = 1 To 6
If j4 = j3 Or j4 = j2 Or j4 = j1 Then GoTo 40
For j5 = 1 To 6
If j5 = j4 Or j5 = j3 Or j5 = j2 Or j5 = j1 Then GoTo 50
For j6 = 1 To 6
If j6 = j5 Or j6 = j4 Or j6 = j3 Or j6 = j2 Or j6 = j1 Then GoTo 60
n9 = n9 + 1
GoSub 100 'Load Square Ai
GoSub 600 'Print Square Ai
60 Next j6
50 Next j5
40 Next j4
30 Next j3
20 Next j2
10 Next j1
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
y = MsgBox(t10, 0, "Routine SudSqr7a")
End
' A1: shift 2 columns to the left
' A2: shift 3 columns to the left
' A3: shift 2 columns to the right
' A4: shift 3 columns to the right
' Load Square A1
100 a(1) = 0: a(2) = j1: a(3) = j2: a(4) = j3: a(5) = j4: a(6) = j5: a(7) = j6
a(8) = a(3): a(9) = a(4): a(10) = a(5): a(11) = a(6): a(12) = a(7): a(13) = a(1): a(14) = a(2)
a(15) = a(5): a(16) = a(6): a(17) = a(7): a(18) = a(1): a(19) = a(2): a(20) = a(3): a(21) = a(4)
a(22) = a(7): a(23) = a(1): a(24) = a(2): a(25) = a(3): a(26) = a(4): a(27) = a(5): a(28) = a(6)
a(29) = a(2): a(30) = a(3): a(31) = a(4): a(32) = a(5): a(33) = a(6): a(34) = a(7): a(35) = a(1)
a(36) = a(4): a(37) = a(5): a(38) = a(6): a(39) = a(7): a(40) = a(1): a(41) = a(2): a(42) = a(3)
a(43) = a(6): a(44) = a(7): a(45) = a(1): a(46) = a(2): a(47) = a(3): a(48) = a(4): a(49) = a(5)
Return
' Load Square A2
110 a(1) = 0: a(2) = j1: a(3) = j2: a(4) = j3: a(5) = j4: a(6) = j5: a(7) = j6
a(8) = a(4): a(9) = a(5): a(10) = a(6): a(11) = a(7): a(12) = a(1): a(13) = a(2): a(14) = a(3)
a(15) = a(7): a(16) = a(1): a(17) = a(2): a(18) = a(3): a(19) = a(4): a(20) = a(5): a(21) = a(6)
a(22) = a(3): a(23) = a(4): a(24) = a(5): a(25) = a(6): a(26) = a(7): a(27) = a(1): a(28) = a(2)
a(29) = a(6): a(30) = a(7): a(31) = a(1): a(32) = a(2): a(33) = a(3): a(34) = a(4): a(35) = a(5)
a(36) = a(2): a(37) = a(3): a(38) = a(4): a(39) = a(5): a(40) = a(6): a(41) = a(7): a(42) = a(1)
a(43) = a(5): a(44) = a(6): a(45) = a(7): a(46) = a(1): a(47) = a(2): a(48) = a(3): a(49) = a(4)
Return
' Load Square A3
120 a(1) = 0: a(2) = j1: a(3) = j2: a(4) = j3: a(5) = j4: a(6) = j5: a(7) = j6
a(8) = a(6): a(9) = a(7): a(10) = a(1): a(11) = a(2): a(12) = a(3): a(13) = a(4): a(14) = a(5)
a(15) = a(4): a(16) = a(5): a(17) = a(6): a(18) = a(7): a(19) = a(1): a(20) = a(2): a(21) = a(3)
a(22) = a(2): a(23) = a(3): a(24) = a(4): a(25) = a(5): a(26) = a(6): a(27) = a(7): a(28) = a(1)
a(29) = a(7): a(30) = a(1): a(31) = a(2): a(32) = a(3): a(33) = a(4): a(34) = a(5): a(35) = a(6)
a(36) = a(5): a(37) = a(6): a(38) = a(7): a(39) = a(1): a(40) = a(2): a(41) = a(3): a(42) = a(4)
a(43) = a(3): a(44) = a(4): a(45) = a(5): a(46) = a(6): a(47) = a(7): a(48) = a(1): a(49) = a(2)
Return
' Load Square A4
130 a(1) = 0: a(2) = j1: a(3) = j2: a(4) = j3: a(5) = j4: a(6) = j5: a(7) = j6
a(8) = a(5): a(9) = a(6): a(10) = a(7): a(11) = a(1): a(12) = a(2): a(13) = a(3): a(14) = a(4)
a(15) = a(2): a(16) = a(3): a(17) = a(4): a(18) = a(5): a(19) = a(6): a(20) = a(7): a(21) = a(1)
a(22) = a(6): a(23) = a(7): a(24) = a(1): a(25) = a(2): a(26) = a(3): a(27) = a(4): a(28) = a(5)
a(29) = a(3): a(30) = a(4): a(31) = a(5): a(32) = a(6): a(33) = a(7): a(34) = a(1): a(35) = a(2)
a(36) = a(7): a(37) = a(1): a(38) = a(2): a(39) = a(3): a(40) = a(4): a(41) = a(5): a(42) = a(6)
a(43) = a(4): a(44) = a(5): a(45) = a(6): a(46) = a(7): a(47) = a(1): a(48) = a(2): a(49) = a(3)
Return
' Print results (selected numbers)
500 For i1 = 1 To 49
Cells(n9, i1).Value = a(i1)
Next i1
Return
' Print results (squares)
600 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, 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
End Sub
