' 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

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 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

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

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

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

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