Vorige Pagina About the Author

' 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

Vorige Pagina About the Author