Vorige Pagina About the Author

' Generates Sudoku Comparable Squares of order 8 {B2} for integers 0 thru 7 with following properties:
' - The half columns sum to half the Magic Sum;
' - The Semi Diagonals (2 ea) sum to the Magic Sum;
' - The 4 x 2 rectangles from top to bottom sum (partly) to the Magic Sum.

' Tested with Office 2007 under Windows 7

Sub Sudoku8b2()

Dim a(64), b(8), s9(10)

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

n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 7: s1 = 28

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

For j64 = m1 To m2                                            'a(64) = 7
    a(64) = j64

For j63 = m1 To m2                                            'a(63) = 6
    If j63 = j64 Then GoTo 630
    a(63) = j63

For j62 = m1 To m2                                            'a(62) = 3
    If j62 = j63 Or j62 = j64 Then GoTo 620
    a(62) = j62

For j61 = m1 To m2                                            'a(62) = 2
    If j61 = j62 Or j61 = j63 Or j61 = j64 Then GoTo 610
    a(61) = j61

For j60 = m1 To m2                                            'a(60) = 1
    If j60 = j61 Or j60 = j62 Or j60 = j63 Or j60 = j64 Then GoTo 600
    a(60) = j60

For j59 = m1 To m2                                            'a(59) = 0
    If j59 = j60 Or j59 = j61 Or j59 = j62 Or j59 = j63 Or j59 = j64 Then GoTo 590
    a(59) = j59

For j58 = m1 To m2                                            'a(58) = 5
    If j58 = j59 Or j58 = j60 Or j58 = j61 Or j58 = j62 Or j58 = j63 Or j58 = j64 Then GoTo 580
    a(58) = j58

    a(57) = s1 - a(58) - a(59) - a(60) - a(61) - a(62) - a(63) - a(64)
    If a(57) < m1 Or a(57) > m2 Then GoTo 580
    j57 = a(57)
    If j57 = j58 Or j57 = j59 Or j57 = j60 Or j57 = j61 Or j57 = j62 Or j57 = j63 Or j57 = j64 Then GoTo 580
    
For j56 = m1 To m2                                            'a(56) = 0
    a(56) = j56

For j55 = m1 To m2                                            'a(55) = 1
    If j55 = j56 Then GoTo 550
    a(55) = j55
    
For j54 = m1 To m2                                            'a(54) = 4
    If j54 = j55 Or j54 = j56 Then GoTo 540
    a(54) = j54

    a(53) = s1 - a(54) - a(55) - a(56) - a(61) - a(62) - a(63) - a(64)
    If a(53) < m1 Or a(53) > m2 Then GoTo 540
    j53 = a(53)
    If j53 = j54 Or j53 = j55 Or j53 = j56 Then GoTo 540
    
    a(52) = a(56) - a(60) + a(64)
    If a(52) < m1 Or a(52) > m2 Then GoTo 540
    j52 = a(52)
    If j52 = j53 Or j52 = j54 Or j52 = j55 Or j52 = j56 Then GoTo 540

    a(51) = a(55) - a(59) + a(63)
    If a(51) < m1 Or a(51) > m2 Then GoTo 540
    j51 = a(51)
    If j51 = j52 Or j51 = j53 Or j51 = j54 Or j51 = j55 Or j51 = j56 Then GoTo 540

    a(50) = a(54) - a(58) + a(62)
    If a(50) < m1 Or a(50) > m2 Then GoTo 540
    j50 = a(50)
    If j50 = j51 Or j50 = j52 Or j50 = j53 Or j50 = j54 Or j50 = j55 Or j50 = j56 Then GoTo 540

    a(49) = a(53) - a(57) + a(61)
    If a(49) < m1 Or a(49) > m2 Then GoTo 540
    j49 = a(49)
    If j49 = j50 Or j49 = j51 Or j49 = j52 Or j49 = j53 Or j49 = j54 Or j49 = j55 Or j49 = j56 Then GoTo 540

For j48 = m1 To m2                                            'a(48) = 6
    a(48) = j48

For j47 = m1 To m2                                            'a(47) = 7
    If j47 = j48 Then GoTo 470
    a(47) = j47

For j46 = m1 To m2                                            'a(46) = 2
    If j46 = j47 Or j46 = j48 Then GoTo 460
    a(46) = j46

    a(45) = -a(46) - a(47) - a(48) + a(61) + a(62) + a(63) + a(64)
    If a(45) < m1 Or a(45) > m2 Then GoTo 460
    j45 = a(45)
    If j45 = j46 Or j45 = j47 Or j45 = j48 Then GoTo 460

For j44 = m1 To m2                                            'a(44) = 0
    If j44 = j45 Or j44 = j46 Or j44 = j47 Or j44 = j48 Then GoTo 440
    a(44) = j44

    a(43) = -a(44) + a(47) + a(48) + a(59) + a(60) - a(63) - a(64)
    If a(43) < m1 Or a(43) > m2 Then GoTo 440
    j43 = a(43)
    If j43 = j44 Or j43 = j45 Or j43 = j46 Or j43 = j47 Or j43 = j48 Then GoTo 440
    
For j42 = m1 To m2                                            'a(42) = 4
    If j42 = j43 Or j42 = j44 Or j42 = j45 Or j42 = j46 Or j42 = j47 Or j42 = j48 Then GoTo 420
    a(42) = j42
    
    a(41) = s1 - a(42) - a(47) - a(48) - a(59) - a(60) - a(61) - a(62)
    If a(41) < m1 Or a(41) > m2 Then GoTo 420
    a(40) = s1 / 2 - a(48) - a(56) - a(64)
    If a(40) < m1 Or a(40) > m2 Then GoTo 420
    a(39) = s1 / 2 - a(47) - a(55) - a(63)
    If a(39) < m1 Or a(39) > m2 Then GoTo 420
    a(38) = s1 / 2 - a(46) - a(54) - a(62)
    If a(38) < m1 Or a(38) > m2 Then GoTo 420
    a(37) = -s1 / 2 + a(46) + a(47) + a(48) + a(54) + a(55) + a(56) - a(61)
    If a(37) < m1 Or a(37) > m2 Then GoTo 420
    a(36) = s1 / 2 - a(44) - a(56) - a(64)
    If a(36) < m1 Or a(36) > m2 Then GoTo 420
    a(35) = s1 / 2 + a(44) - a(47) - a(48) - a(55) - a(59) - a(60) + a(64)
    If a(35) < m1 Or a(35) > m2 Then GoTo 420
    a(34) = s1 / 2 - a(42) - a(54) - a(62)
    If a(34) < m1 Or a(34) > m2 Then GoTo 420
    a(33) = s1 / 2 + a(42) + a(47) + a(48) - a(53) - a(57) - a(58) - a(61) - a(63) - a(64)
    If a(33) < m1 Or a(33) > m2 Then GoTo 420

    a(32) = s1 / 4 - a(33): a(31) = s1 / 4 - a(34): a(30) = s1 / 4 - a(35): a(29) = s1 / 4 - a(36):
    a(28) = s1 / 4 - a(37): a(27) = s1 / 4 - a(38): a(26) = s1 / 4 - a(39): a(25) = s1 / 4 - a(40):
    a(24) = s1 / 4 - a(41): a(23) = s1 / 4 - a(42): a(22) = s1 / 4 - a(43): a(21) = s1 / 4 - a(44):
    a(20) = s1 / 4 - a(45): a(19) = s1 / 4 - a(46): a(18) = s1 / 4 - a(47): a(17) = s1 / 4 - a(48):
    a(16) = s1 / 4 - a(49): a(15) = s1 / 4 - a(50): a(14) = s1 / 4 - a(51): a(13) = s1 / 4 - a(52):
    a(12) = s1 / 4 - a(53): a(11) = s1 / 4 - a(54): a(10) = s1 / 4 - a(55): a(9) = s1 / 4 - a(56):
    a(8) = s1 / 4 - a(57):  a(7) = s1 / 4 - a(58):  a(6) = s1 / 4 - a(59):  a(5) = s1 / 4 - a(60):
    a(4) = s1 / 4 - a(61):  a(3) = s1 / 4 - a(62):  a(2) = s1 / 4 - a(63):  a(1) = s1 / 4 - a(64):

'                          Exclude solutions with identical numbers in:
'                          rows (8), columns (8), subrectangles (20), main - and semi diagonals (4)

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

420 Next j42

440 Next j44

460 Next j46
470 Next j47
480 Next j48

540 Next j54
550 Next j55
560 Next j56

580 Next j58
590 Next j59
600 Next j60
610 Next j61
620 Next j62
630 Next j63
640 Next j64
    
    t2 = Timer
    
    t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
    y = MsgBox(t10, 0, "Routine Sudoku8b2")

End

'                          Exclude solutions with identical numbers in:
'                          rows (8), columns (8), subrectangles (20), main and semi diagonals (4)

1800

'    Rows
    
     i1 = -7
     For i0 = 1 To 8
         i1 = i1 + 8
         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)
         GoSub 1860: If fl1 = 0 Then Return
     Next i0

'    Columns
    
     i1 = 0
     For i0 = 1 To 8
         i1 = i1 + 1
         b(1) = a(i1):      b(2) = a(i1 + 8):  b(3) = a(i1 + 16): b(4) = a(i1 + 24):
         b(5) = a(i1 + 32): b(6) = a(i1 + 40): b(7) = a(i1 + 48): b(8) = a(i1 + 56)
         GoSub 1860: If fl1 = 0 Then Return
     Next i0

'    Main Diagonals

     b(1) = a(1): b(2) = a(10): b(3) = a(19): b(4) = a(28): b(5) = a(37): b(6) = a(46): b(7) = a(55): b(8) = a(64)
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(8): b(2) = a(15): b(3) = a(22): b(4) = a(29): b(5) = a(36): b(6) = a(43): b(7) = a(50): b(8) = a(57)
     GoSub 1860: If fl1 = 0 Then Return
    
'    Semi Diagonals

     b(1) = a(25): b(2) = a(18): b(3) = a(11): b(4) = a(4): b(5) = a(40): b(6) = a(47): b(7) = a(54): b(8) = a(61)
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(5): b(2) = a(14): b(3) = a(23): b(4) = a(32): b(5) = a(33): b(6) = a(42): b(7) = a(51): b(8) = a(60)
     GoSub 1860: If fl1 = 0 Then Return

'    Sudoku Comparable  Rectangles (Optional, ref, SudSqr8b: Example)
     
     b(1) = a(1): b(2) = a(2): b(3) = a(3): b(4) = a(4): b(5) = a(9): b(6) = a(10): b(7) = a(11): b(8) = a(12):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(3): b(2) = a(4): b(3) = a(5): b(4) = a(6): b(5) = a(11): b(6) = a(12): b(7) = a(13): b(8) = a(14):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(5): b(2) = a(6): b(3) = a(7): b(4) = a(8): b(5) = a(13): b(6) = a(14): b(7) = a(15): b(8) = a(16):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(1): b(2) = a(2): b(3) = a(9): b(4) = a(10): b(5) = a(7): b(6) = a(8): b(7) = a(15): b(8) = a(16):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(9): b(2) = a(10): b(3) = a(11): b(4) = a(12): b(5) = a(17): b(6) = a(18): b(7) = a(19): b(8) = a(20):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(11): b(2) = a(12): b(3) = a(13): b(4) = a(14): b(5) = a(19): b(6) = a(20): b(7) = a(21): b(8) = a(22):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(13): b(2) = a(14): b(3) = a(15): b(4) = a(16): b(5) = a(21): b(6) = a(22): b(7) = a(23): b(8) = a(24):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(9): b(2) = a(10): b(3) = a(17): b(4) = a(18): b(5) = a(15): b(6) = a(16): b(7) = a(23): b(8) = a(24):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(17): b(2) = a(18): b(3) = a(19): b(4) = a(20): b(5) = a(25): b(6) = a(26): b(7) = a(27): b(8) = a(28):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(19): b(2) = a(20): b(3) = a(21): b(4) = a(22): b(5) = a(27): b(6) = a(28): b(7) = a(29): b(8) = a(30):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(21): b(2) = a(22): b(3) = a(23): b(4) = a(24): b(5) = a(29): b(6) = a(30): b(7) = a(31): b(8) = a(32):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(17): b(2) = a(18): b(3) = a(25): b(4) = a(26): b(5) = a(23): b(6) = a(24): b(7) = a(31): b(8) = a(32):
     GoSub 1860: If fl1 = 0 Then Return

     b(1) = a(27): b(2) = a(28): b(3) = a(29): b(4) = a(30): b(5) = a(35): b(6) = a(36): b(7) = a(37): b(8) = a(38):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(25): b(2) = a(26): b(3) = a(33): b(4) = a(34): b(5) = a(31): b(6) = a(32): b(7) = a(39): b(8) = a(40):
     GoSub 1860: If fl1 = 0 Then Return

     b(1) = a(33): b(2) = a(34): b(3) = a(35): b(4) = a(36): b(5) = a(41): b(6) = a(42): b(7) = a(43): b(8) = a(44):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(35): b(2) = a(36): b(3) = a(37): b(4) = a(38): b(5) = a(43): b(6) = a(44): b(7) = a(45): b(8) = a(46):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(37): b(2) = a(38): b(3) = a(39): b(4) = a(40): b(5) = a(45): b(6) = a(46): b(7) = a(47): b(8) = a(48):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(33): b(2) = a(34): b(3) = a(41): b(4) = a(42): b(5) = a(39): b(6) = a(40): b(7) = a(47): b(8) = a(48):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(41): b(2) = a(42): b(3) = a(43): b(4) = a(44): b(5) = a(49): b(6) = a(50): b(7) = a(51): b(8) = a(52):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(43): b(2) = a(44): b(3) = a(45): b(4) = a(46): b(5) = a(51): b(6) = a(52): b(7) = a(53): b(8) = a(54):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(45): b(2) = a(46): b(3) = a(47): b(4) = a(48): b(5) = a(53): b(6) = a(54): b(7) = a(55): b(8) = a(56):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(41): b(2) = a(42): b(3) = a(49): b(4) = a(50): b(5) = a(47): b(6) = a(48): b(7) = a(55): b(8) = a(56):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(49): b(2) = a(50): b(3) = a(51): b(4) = a(52): b(5) = a(57): b(6) = a(58): b(7) = a(59): b(8) = a(60):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(51): b(2) = a(52): b(3) = a(53): b(4) = a(54): b(5) = a(59): b(6) = a(60): b(7) = a(61): b(8) = a(62):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(53): b(2) = a(54): b(3) = a(55): b(4) = a(56): b(5) = a(61): b(6) = a(62): b(7) = a(63): b(8) = a(64):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(49): b(2) = a(50): b(3) = a(57): b(4) = a(58): b(5) = a(55): b(6) = a(56): b(7) = a(63): b(8) = a(64):
     GoSub 1860: If fl1 = 0 Then Return

     b(1) = a(3): b(2) = a(4): b(3) = a(5): b(4) = a(6): b(5) = a(59): b(6) = a(60): b(7) = a(61): b(8) = a(62):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(1): b(2) = a(2): b(3) = a(57): b(4) = a(58): b(5) = a(7): b(6) = a(8): b(7) = a(63): b(8) = a(64):
     GoSub 1860: If fl1 = 0 Then Return

     b(1) = a(1): b(2) = a(2): b(3) = a(3): b(4) = a(4): b(5) = a(25): b(6) = a(26): b(7) = a(27): b(8) = a(28):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(3): b(2) = a(4): b(3) = a(5): b(4) = a(6): b(5) = a(27): b(6) = a(28): b(7) = a(29): b(8) = a(30):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(5): b(2) = a(6): b(3) = a(7): b(4) = a(8): b(5) = a(29): b(6) = a(30): b(7) = a(31): b(8) = a(32):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(1): b(2) = a(2): b(3) = a(25): b(4) = a(26): b(5) = a(7): b(6) = a(8): b(7) = a(31): b(8) = a(32):
     GoSub 1860: If fl1 = 0 Then Return

     b(1) = a(33): b(2) = a(34): b(3) = a(35): b(4) = a(36): b(5) = a(57): b(6) = a(58): b(7) = a(59): b(8) = a(60):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(35): b(2) = a(36): b(3) = a(37): b(4) = a(38): b(5) = a(59): b(6) = a(60): b(7) = a(61): b(8) = a(62):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(37): b(2) = a(38): b(3) = a(39): b(4) = a(40): b(5) = a(61): b(6) = a(62): b(7) = a(63): b(8) = a(64):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(33): b(2) = a(34): b(3) = a(57): b(4) = a(58): b(5) = a(39): b(6) = a(40): b(7) = a(63): b(8) = a(64):
     GoSub 1860: If fl1 = 0 Then Return

     Return
    
'    Check identical numbers
    
1860 fl1 = 1
     For j10 = 1 To 8
        b2 = b(j10)
        For j20 = (1 + j10) To 8
            If b2 = b(j20) Then fl1 = 0: Return
        Next j20
     Next j10
     Return

'   Print results (selected numbers)

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

'   Print results (squares)

2650 n2 = n2 + 1
     If n2 = 5 Then
         n2 = 1: k1 = k1 + 9: k2 = 1
     Else
         If n9 > 1 Then k2 = k2 + 9
     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 8
         For i2 = 1 To 8
             i3 = i3 + 1
             Cells(k1 + i1, k2 + i2).Value = a(i3)
         Next i2
     Next i1
    
     Return

End Sub

Vorige Pagina About the Author