Vorige Pagina About the Author

' Generates Bimagic Squares of order 8, Magic Sum 260, André Gérardin
' Based on Sudoku Comparable Lines

' Tested with Office 2007 under Windows 7

Sub CnstrSqrs06()

Dim a(64), b(64), c(64), s(34)

y = MsgBox("Blocked", vbCritical, "CnstrSqrs06")
End

n2 = 0: n9 = 0: k1 = 1: k2 = 1

Sheets("Klad1").Select

For j1 = 2 To 49

    GoSub 100                               'Read a()
    
    For j2 = 2 To 49

        GoSub 200                           'Read b()
        
        For j3 = 1 To 64                    'Calcualte c()
            c(j3) = 8 * a(j3) + b(j3) + 1
        Next j3
    
        GoSub 300: If fl1 = 0 Then GoTo 20  'Check Identical Numbers
        GoSub 400: If fl1 = 0 Then GoTo 20  'Check Magic    Sum
        GoSub 500: If fl1 = 0 Then GoTo 20  'Check Bimagic  Sum
        GoSub 600: If fl1 = 0 Then GoTo 20  'Check Trimagic Sum (Main and Semi Diagonals)

'       n9 = n9 + 1: GoSub 1000             'Print first lines (Test)
        n9 = n9 + 1: GoSub 2650             'Print results     (Squares)
    
20  Next j2
10 Next j1

End

'   Read a() A   L   T   K   I   R   C   H

100 For j3 = 1 To 8
        a(j3) = Sheets("RangeA").Cells(j1, j3).Value
    Next j3
    
    a(9)  = a(3):a(10) = a(4):a(11) = a(1):a(12) = a(2):a(13) = a(7):a(14) = a(8):a(15) = a(5):a(16) = a(6):
    a(17) = a(8):a(18) = a(7):a(19) = a(6):a(20) = a(5):a(21) = a(4):a(22) = a(3):a(23) = a(2):a(24) = a(1):
    a(25) = a(6):a(26) = a(5):a(27) = a(8):a(28) = a(7):a(29) = a(2):a(30) = a(1):a(31) = a(4):a(32) = a(3):
    a(33) = a(7):a(34) = a(8):a(35) = a(5):a(36) = a(6):a(37) = a(3):a(38) = a(4):a(39) = a(1):a(40) = a(2):
    a(41) = a(5):a(42) = a(6):a(43) = a(7):a(44) = a(8):a(45) = a(1):a(46) = a(2):a(47) = a(3):a(48) = a(4):
    a(49) = a(2):a(50) = a(1):a(51) = a(4):a(52) = a(3):a(53) = a(6):a(54) = a(5):a(55) = a(8):a(56) = a(7):
    a(57) = a(4):a(58) = a(3):a(59) = a(2):a(60) = a(1):a(61) = a(8):a(62) = a(7):a(63) = a(6):a(64) = a(5):
    Return
    
'   Read b() e   s   p   a   l   i   o   n
    
200 For j3 = 1 To 8
        b(j3) = Sheets("RangeB").Cells(j2, j3).Value
    Next j3
    
    b(9)  = b(4):b(10) = b(3):b(11) = b(2):b(12) = b(1):b(13) = b(8):b(14) = b(7):b(15) = b(6):b(16) = b(5):
    b(17) = b(5):b(18) = b(6):b(19) = b(7):b(20) = b(8):b(21) = b(1):b(22) = b(2):b(23) = b(3):b(24) = b(4):
    b(25) = b(8):b(26) = b(7):b(27) = b(6):b(28) = b(5):b(29) = b(4):b(30) = b(3):b(31) = b(2):b(32) = b(1):
    b(33) = b(2):b(34) = b(1):b(35) = b(4):b(36) = b(3):b(37) = b(6):b(38) = b(5):b(39) = b(8):b(40) = b(7):
    b(41) = b(3):b(42) = b(4):b(43) = b(1):b(44) = b(2):b(45) = b(7):b(46) = b(8):b(47) = b(5):b(48) = b(6):
    b(49) = b(6):b(50) = b(5):b(51) = b(8):b(52) = b(7):b(53) = b(2):b(54) = b(1):b(55) = b(4):b(56) = b(3):
    b(57) = b(7):b(58) = b(8):b(59) = b(5):b(60) = b(6):b(61) = b(3):b(62) = b(4):b(63) = b(1):b(64) = b(2):
    Return

'   Check Identical Numbers

300 fl1 = 1
    For j10 = 1 To 64
        c2 = c(j10)
        For j20 = (1 + j10) To 64
            If c2 = c(j20) Then fl1 = 0: Return
        Next j20
   Next j10
   Return

'   Check Magic Sum

400 fl1 = 1

'   Rows

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

'   Columns

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

'   Pan Diagonals

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

    s(25) = c(8) + c(15) + c(22) + c(29) + c(36) + c(43) + c(50) + c(57)    'Main
    s(26) = c(1) + c(16) + c(23) + c(30) + c(37) + c(44) + c(51) + c(58)
    s(27) = c(2) + c(9) + c(24) + c(31) + c(38) + c(45) + c(52) + c(59)
    s(28) = c(3) + c(10) + c(17) + c(32) + c(39) + c(46) + c(53) + c(60)
    s(29) = c(4) + c(11) + c(18) + c(25) + c(40) + c(47) + c(54) + c(61)    'Semi
    s(30) = c(5) + c(12) + c(19) + c(26) + c(33) + c(48) + c(55) + c(62)
    s(31) = c(6) + c(13) + c(20) + c(27) + c(34) + c(41) + c(56) + c(63)
    s(32) = c(7) + c(14) + c(21) + c(28) + c(35) + c(42) + c(49) + c(64)
    
    For i1 = 1 To 32
        If s(i1) <> 260 Then fl1 = 0: Return
    Next i1
    
    Return

'   Check Bimagic Sum

500 fl1 = 1

'   Rows

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

'   Columns

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

'   Pan Diagonals

    s(17) = c(1) ^ 2 + c(10) ^ 2 + c(19) ^ 2 + c(28) ^ 2 + c(37) ^ 2 + c(46) ^ 2 + c(55) ^ 2 + c(64) ^ 2 'Main
    s(18) = c(5) ^ 2 + c(14) ^ 2 + c(23) ^ 2 + c(32) ^ 2 + c(33) ^ 2 + c(42) ^ 2 + c(51) ^ 2 + c(60) ^ 2 'Semi

    s(19) = c(8) ^ 2 + c(15) ^ 2 + c(22) ^ 2 + c(29) ^ 2 + c(36) ^ 2 + c(43) ^ 2 + c(50) ^ 2 + c(57) ^ 2 'Main
    s(20) = c(4) ^ 2 + c(11) ^ 2 + c(18) ^ 2 + c(25) ^ 2 + c(40) ^ 2 + c(47) ^ 2 + c(54) ^ 2 + c(61) ^ 2 'Semi
    
    For i1 = 1 To 20
        If s(i1) <> 11180 Then fl1 = 0: Return
    Next i1
    
    Return
    
'   Check Trimagic Sum (Main and Semi Diagonals)

600 fl1 = 1

    s(1) = c(1) ^ 3 + c(10) ^ 3 + c(19) ^ 3 + c(28) ^ 3 + c(37) ^ 3 + c(46) ^ 3 + c(55) ^ 3 + c(64) ^ 3 'Main
    s(2) = c(5) ^ 3 + c(14) ^ 3 + c(23) ^ 3 + c(32) ^ 3 + c(33) ^ 3 + c(42) ^ 3 + c(51) ^ 3 + c(60) ^ 3 'Semi

    s(3) = c(8) ^ 3 + c(15) ^ 3 + c(22) ^ 3 + c(29) ^ 3 + c(36) ^ 3 + c(43) ^ 3 + c(50) ^ 3 + c(57) ^ 3 'Main
    s(4) = c(4) ^ 3 + c(11) ^ 3 + c(18) ^ 3 + c(25) ^ 3 + c(40) ^ 3 + c(47) ^ 3 + c(54) ^ 3 + c(61) ^ 3 'Semi

    For i1 = 1 To 4
        If s(i1) <> 540800 Then fl1 = 0: Return
    Next i1

    Return

'   Print Squares

700

    Return
    
'   Print Lines
    
1000 Cells(n9, 28).Select
     For i1 = 1 To 8
         Cells(n9, i1).Value = a(i1)
         Cells(n9, i1 + 9).Value = b(i1)
         Cells(n9, i1 + 18).Value = c(i1)
     Next i1
     Cells(n9, 27).Value = j1
     Cells(n9, 28).Value = j2
    
    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 = c(i3)
         Next i2
     Next i1
    
     Return
    
End Sub

Vorige Pagina About the Author