Vorige Pagina About the Author

' Generates Sudoku Comparable Associated Compact Pan Magic Squares of order 9 for integers 0 thru 8

' Tested with Office 2007 under Windows 7

Sub SudSqr9a()

Dim a(81), b(9)

y = MsgBox("Locked", vbCritical, "Routine SudSqr9a")
End

n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 8: s1 = 36: s2 = s1 / 9

'   Generate data
    
    Sheets("Klad1").Select
    
    t1 = Timer

a(41) = s2

For j81 = m1 To m2                                            'a(81)
    a(81) = j81

    a(1) = 2 * s2 - a(81)

For j80 = m1 To m2                                            'a(80)
    a(80) = j80

    a(79) = 3 * s2 - a(80) - a(81): If a(79) < m1 Or a(79) > m2 Then GoTo 800
    a(3) = 2 * s2 - a(79): a(2) = 2 * s2 - a(80)

For j78 = m1 To m2                                            'a(78)
    a(78) = j78

    a(4) = 2 * s2 - a(78)

For j77 = m1 To m2                                            'a(77)
    a(77) = j77

    a(76) = 3 * s2 - a(77) - a(78): If a(76) < m1 Or a(76) > m2 Then GoTo 770
    a(6) = 2 * s2 - a(76): a(5) = 2 * s2 - a(77)

For j75 = m1 To m2                                            'a(75)
    a(75) = j75

    a(7) = 2 * s2 - a(75)

For j74 = m1 To m2                                            'a(74)
    a(74) = j74

    a(73) = 3 * s2 - a(74) - a(75): If a(73) < m1 Or a(73) > m2 Then GoTo 740
    a(44) = s2 + a(74) - a(80): If a(44) < m1 Or a(44) > m2 Then GoTo 740
    a(9) = 2 * s2 - a(73): a(8) = 2 * s2 - a(74)

For j72 = m1 To m2                                            'a(72)
    a(72) = j72

    a(69) = a(72) + a(74) + a(75) - a(77) - 2 * a(78) + a(81): If a(69) < m1 Or a(69) > m2 Then GoTo 720
    a(66) = a(72) + a(74) - a(80): If a(66) < m1 Or a(66) > m2 Then GoTo 720
    a(63) = 3 * s2 - a(72) - a(81): If a(63) < m1 Or a(63) > m2 Then GoTo 720
    a(60) = 3 * s2 - a(72) - a(74) - a(75) + a(77) + a(78) - a(81): If a(60) < m1 Or a(60) > m2 Then GoTo 720
    a(57) = 3 * s2 - a(72) - a(74) - a(75) + a(80): If a(57) < m1 Or a(57) > m2 Then GoTo 720
    a(52) = s2 - a(72) + a(77) + a(78) - 1 * a(81): If a(52) < m1 Or a(52) > m2 Then GoTo 720
    a(49) = s2 - a(72) + a(80): If a(49) < m1 Or a(49) > m2 Then GoTo 720
    a(46) = s2 - a(72) - a(74) - a(75) + a(77) + a(78) + a(80): If a(46) < m1 Or a(46) > m2 Then GoTo 720
    a(10) = 2 * s2 - a(72)

For j71 = m1 To m2                                            'a(71)
    a(71) = j71

    a(70) = 3 * s2 - a(71) - a(72): If a(70) < m1 Or a(70) > m2 Then GoTo 710
    a(68) = a(71) - a(74) + a(80): If a(68) < m1 Or a(68) > m2 Then GoTo 710
    a(67) = 3 * s2 - a(71) - a(72) - a(75) + a(77) + 2 * a(78) - a(80) - a(81): If a(67) < m1 Or a(67) > m2 Then GoTo 710
    a(65) = a(71) - 2 * a(74) + 2 * a(80): If a(65) < m1 Or a(65) > m2 Then GoTo 710
    a(64) = 3 * s2 - a(71) - a(72) + a(74) - a(80): If a(64) < m1 Or a(64) > m2 Then GoTo 710
    a(62) = 3 * s2 - a(71) - a(80): If a(62) < m1 Or a(62) > m2 Then GoTo 710
    a(61) = -3 * s2 + a(71) + a(72) + a(80) + a(81): If a(61) < m1 Or a(61) > m2 Then GoTo 710
    a(59) = 3 * s2 - a(71) + a(74) - a(77) - a(80): If a(59) < m1 Or a(59) > m2 Then GoTo 710
    a(58) = -3 * s2 + a(71) + a(72) + a(75) - a(78) + a(80) + a(81): If a(58) < m1 Or a(58) > m2 Then GoTo 710
    a(56) = 3 * s2 - a(71) + a(74) - 2 * a(80): If a(56) < m1 Or a(56) > m2 Then GoTo 710
    a(55) = -3 * s2 + a(71) + a(72) + a(75) + a(80): If a(55) < m1 Or a(55) > m2 Then GoTo 710
    a(54) = -2 * s2 + a(71) + a(72) - a(78) + a(80) + a(81): If a(54) < m1 Or a(54) > m2 Then GoTo 710
    a(53) = 4 * s2 - a(71) - a(77) - a(80): If a(53) < m1 Or a(53) > m2 Then GoTo 710
    a(51) = -2 * s2 + a(71) + a(72) + a(80): If a(51) < m1 Or a(51) > m2 Then GoTo 710
    a(50) = 4 * s2 - a(71) - 2 * a(80): If a(50) < m1 Or a(50) > m2 Then GoTo 710
    a(48) = -2 * s2 + a(71) + a(72) + a(75) - a(78) + a(80): If a(48) < m1 Or a(48) > m2 Then GoTo 710
    a(47) = 4 * s2 - a(71) + a(74) - a(77) - 2 * a(80): If a(47) < m1 Or a(47) > m2 Then GoTo 710
    a(45) = 4 * s2 - a(71) - 2 * a(72) - a(74) - a(75) + a(77) + 2 * a(78) - a(81): If a(45) < m1 Or a(45) > m2 Then GoTo 710
    a(43) = -2 * s2 + a(71) + 2 * a(72) + a(75) - a(77) - 2 * a(78) + a(80) + a(81): If a(43) < m1 Or a(43) > m2 Then GoTo 710
    a(42) = 4 * s2 - a(71) - 2 * a(72): If a(42) < m1 Or a(42) > m2 Then GoTo 710
    
    a(40) = 2 * s2 - a(42): a(39) = 2 * s2 - a(43): a(38) = 2 * s2 - a(44): a(37) = 2 * s2 - a(45): a(36) = 2 * s2 - a(46):
    a(35) = 2 * s2 - a(47): a(34) = 2 * s2 - a(48): a(33) = 2 * s2 - a(49): a(32) = 2 * s2 - a(50): a(31) = 2 * s2 - a(51):
    a(30) = 2 * s2 - a(52): a(29) = 2 * s2 - a(53): a(28) = 2 * s2 - a(54): a(27) = 2 * s2 - a(55): a(26) = 2 * s2 - a(56):
    a(25) = 2 * s2 - a(57): a(24) = 2 * s2 - a(58): a(23) = 2 * s2 - a(59): a(22) = 2 * s2 - a(60): a(21) = 2 * s2 - a(61):
    a(20) = 2 * s2 - a(62): a(19) = 2 * s2 - a(63): a(18) = 2 * s2 - a(64): a(17) = 2 * s2 - a(65): a(16) = 2 * s2 - a(66):
    a(15) = 2 * s2 - a(67): a(14) = 2 * s2 - a(68): a(13) = 2 * s2 - a(69): a(12) = 2 * s2 - a(70): a(11) = 2 * s2 - a(71):

'                          Exclude solutions with identical numbers in rows, columns, diagonals, sub squares (9)

                           GoSub 1800: If fl1 = 0 Then GoTo 710
                           
                           n9 = n9 + 1
                           GoSub 2650      'Print results (squares)
'                          GoSub 2645      'Print results (selected numbers

710 Next j71
720 Next j72
    
740 Next j74
750 Next j75

770 Next j77
780 Next j78

800 Next j80
810 Next j81
    
    t2 = Timer
    
    t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
    y = MsgBox(t10, 0, "Routine SudSqr9a")

End

'   Exclude solutions with identical numbers in rows, columns, diagonals, sub squares (9)

1800 fl1 = 1
    
'   Rows
    
    i1 = -8
    For i0 = 1 To 9
        i1 = i1 + 9
        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): b(8) = a(i1 + 7): b(9) = a(i1 + 8)
        GoSub 1860: If fl1 = 0 Then Return
    Next i0
   
'   Columns
    
    i1 = 0
    For i0 = 1 To 9
        i1 = i1 + 1
        b(1) = a(i1): b(2) = a(i1 + 9): b(3) = a(i1 + 18): b(4) = a(i1 + 27): b(5) = a(i1 + 36)
        b(6) = a(i1 + 45): b(7) = a(i1 + 54): b(8) = a(i1 + 63): b(9) = a(i1 + 72)
        GoSub 1860: If fl1 = 0 Then Return
    Next i0
    
'   Main Diagonals

    b(1) = a(1): b(2) = a(11): b(3) = a(21): b(4) = a(31): b(5) = a(41): b(6) = a(51): b(7) = a(61): b(8) = a(71): b(9) = a(81):
    GoSub 1860: If fl1 = 0 Then Return
    b(1) = a(9): b(2) = a(17): b(3) = a(25): b(4) = a(33): b(5) = a(41): b(6) = a(49): b(7) = a(57): b(8) = a(65): b(9) = a(73):
    GoSub 1860: If fl1 = 0 Then Return
    
'   Sub Squares 3 x 3

    b(1) = a(1): b(2) = a(2): b(3) = a(3): b(4) = a(10): b(5) = a(11): b(6) = a(12): b(7) = a(19): b(8) = a(20): b(9) = a(21):
    GoSub 1860: If fl1 = 0 Then Return
    b(1) = a(4): b(2) = a(5): b(3) = a(6): b(4) = a(13): b(5) = a(14): b(6) = a(15): b(7) = a(22): b(8) = a(23): b(9) = a(24):
    GoSub 1860: If fl1 = 0 Then Return
    b(1) = a(7): b(2) = a(8): b(3) = a(9): b(4) = a(16): b(5) = a(17): b(6) = a(18): b(7) = a(25): b(8) = a(26): b(9) = a(27):
    GoSub 1860: If fl1 = 0 Then Return
    b(1) = a(28): b(2) = a(29): b(3) = a(30): b(4) = a(37): b(5) = a(38): b(6) = a(39): b(7) = a(46): b(8) = a(47): b(9) = a(48):
    GoSub 1860: If fl1 = 0 Then Return
    b(1) = a(31): b(2) = a(32): b(3) = a(33): b(4) = a(40): b(5) = a(41): b(6) = a(42): b(7) = a(49): b(8) = a(50): b(9) = a(51):
    GoSub 1860: If fl1 = 0 Then Return
    b(1) = a(34): b(2) = a(35): b(3) = a(36): b(4) = a(43): b(5) = a(44): b(6) = a(45): b(7) = a(52): b(8) = a(53): b(9) = a(54):
    GoSub 1860: If fl1 = 0 Then Return
    b(1) = a(55): b(2) = a(56): b(3) = a(57): b(4) = a(64): b(5) = a(65): b(6) = a(66): b(7) = a(73): b(8) = a(74): b(9) = a(75):
    GoSub 1860: If fl1 = 0 Then Return
    b(1) = a(58): b(2) = a(59): b(3) = a(60): b(4) = a(67): b(5) = a(68): b(6) = a(69): b(7) = a(76): b(8) = a(77): b(9) = a(78):
    GoSub 1860: If fl1 = 0 Then Return
    b(1) = a(61): b(2) = a(62): b(3) = a(63): b(4) = a(70): b(5) = a(71): b(6) = a(72): b(7) = a(79): b(8) = a(80): b(9) = a(81):
    GoSub 1860: If fl1 = 0 Then Return

    Return
    
1860 fl1 = 1
     For j1 = 1 To 9
        b2 = b(j1)
        For j2 = (1 + j1) To 9
            If b2 = b(j2) Then fl1 = 0: Return
        Next j2
     Next j1
     Return

'   Print results (selected numbers)

2645 For i1 = 1 To 81
         Cells(n9, i1).Value = a(i1)
     Next i1
    
     Return

'   Print results (squares)

2650 n2 = n2 + 1
     If n2 = 5 Then
         n2 = 1: k1 = k1 + 10: k2 = 1
     Else
         If n9 > 1 Then k2 = k2 + 10
     End If
     
     Cells(k1, k2 + 1).Select
     Cells(k1, k2 + 1).Font.Color = -4165632
     Cells(k1, k2 + 1).Value = CStr(n9)
    
     i3 = 0
     For i1 = 1 To 9
         For i2 = 1 To 9
             i3 = i3 + 1
             Cells(k1 + i1, k2 + i2).Value = a(i3)
         Next i2
     Next i1
    
     Return

End Sub

Vorige Pagina About the Author