Vorige Pagina About the Author

' Generates the borders for Eccentric Magic Squares of order 7 for integers as defined in a1()

' Tested with Office 2007 under Windows 7

Sub MgcSqr7h()

Dim a1(24), a(49), b1(140), b(140), c(49)

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

'   Defining Magic Square C (5 x 5)

    a(15) = 151: a(16) = 18:  a(17) = 21:  a(18) = 89:  a(19) = 146:
    a(22) = 27:  a(23) = 82:  a(24) = 150: a(25) = 155: a(26) = 11:
    a(29) = 143: a(30) = 159: a(31) = 15:  a(32) = 20:  a(33) = 88:
    a(36) = 19:  a(37) = 24:  a(38) = 81:  a(39) = 149: a(40) = 152:
    a(43) = 85:  a(44) = 142: a(45) = 158: a(46) = 12:  a(47) = 28:

'   Define Border Variable Values

    a1(1) = 30:   a1(2) = 34:   a1(3) = 35:   a1(4) = 54:   a1(5) = 55:   a1(6) = 56:
    a1(7) = 57:   a1(8) = 58:   a1(9) = 63:   a1(10) = 64:  a1(11) = 65:  a1(12) = 71:
    a1(13) = 99:  a1(14) = 105: a1(15) = 106: a1(16) = 107: a1(17) = 112: a1(18) = 113:
    a1(19) = 114: a1(20) = 115: a1(21) = 116: a1(22) = 135: a1(23) = 136: a1(24) = 140:

    For i1 = 1 To 24
        b1(a1(i1)) = a1(i1)
    Next i1

    n2 = 0: n9 = 0: k1 = 1: k2 = 1
    m1 = 1: m2 = 24: s1 = 595
    
    Sheets("Klad1").Select
    
    t1 = Timer

    For j49 = m1 To m2                                          'a(49)
    If b(a1(j49)) = 0 Then b(a1(j49)) = a1(j49): c(49) = a1(j49) Else GoTo 490
    a(49) = a1(j49)
    
    a(48) = 170 - a(49): If a(48) < a1(m1) Or a(48) > a1(m2) Then GoTo 480
    If b1(a(48)) = 0 Then GoTo 480
    If b(a(48)) = 0 Then b(a(48)) = a(48): c(48) = a(48) Else GoTo 480
    
    For j42 = m1 To m2                                          'a(42)
    If b(a1(j42)) = 0 Then b(a1(j42)) = a1(j42): c(42) = a1(j42) Else GoTo 420
    a(42) = a1(j42)
    
    a(41) = 170 - a(42): If a(41) < a1(m1) Or a(41) > a1(m2) Then GoTo 410
    If b1(a(41)) = 0 Then GoTo 410
    If b(a(41)) = 0 Then b(a(41)) = a(41): c(41) = a(41) Else GoTo 410
    
    For j35 = m1 To m2                                          'a(35)
    If b(a1(j35)) = 0 Then b(a1(j35)) = a1(j35): c(35) = a1(j35) Else GoTo 350
    a(35) = a1(j35)
    
    a(34) = 170 - a(35): If a(34) < a1(m1) Or a(34) > a1(m2) Then GoTo 340
    If b1(a(34)) = 0 Then GoTo 340
    If b(a(34)) = 0 Then b(a(34)) = a(34): c(34) = a(34) Else GoTo 340
    
    For j28 = m1 To m2                                          'a(28)
    If b(a1(j28)) = 0 Then b(a1(j28)) = a1(j28): c(28) = a1(j28) Else GoTo 280
    a(28) = a1(j28)
    
    a(27) = 170 - a(28): If a(27) < a1(m1) Or a(27) > a1(m2) Then GoTo 270
    If b1(a(27)) = 0 Then GoTo 270
    If b(a(27)) = 0 Then b(a(27)) = a(27): c(27) = a(27) Else GoTo 270
    
    For j21 = m1 To m2                                         'a(21)
    If b(a1(j21)) = 0 Then b(a1(j21)) = a1(j21): c(21) = a1(j21) Else GoTo 210
    a(21) = a1(j21)
    
    a(20) = 170 - a(21): If a(20) < a1(m1) Or a(20) > a1(m2) Then GoTo 200
    If b1(a(20)) = 0 Then GoTo 200
    If b(a(20)) = 0 Then b(a(20)) = a(20): c(20) = a(20) Else GoTo 200
    
    For j14 = m1 To m2                                          'a(14)
    If b(a1(j14)) = 0 Then b(a1(j14)) = a1(j14): c(14) = a1(j14) Else GoTo 140
    a(14) = a1(j14)

    a(13) = -425 + a(14) + a(21) + a(28) + a(35) + a(42) + a(49)
    If a(13) < a1(m1) Or a(13) > a1(m2) Then GoTo 130
    If b1(a(13)) = 0 Then GoTo 130
    If b(a(13)) = 0 Then b(a(13)) = a(13): c(13) = a(13) Else GoTo 130
    
    For j12 = m1 To m2                                          'a(12)
    If b(a1(j12)) = 0 Then b(a1(j12)) = a1(j12): c(12) = a1(j12) Else GoTo 120
    a(12) = a1(j12)

    For j11 = m1 To m2                                          'a(11)
    If b(a1(j11)) = 0 Then b(a1(j11)) = a1(j11): c(11) = a1(j11) Else GoTo 110
    a(11) = a1(j11)
 
    For j10 = m1 To m2                                          'a(10)
    If b(a1(j10)) = 0 Then b(a1(j10)) = a1(j10): c(10) = a1(j10) Else GoTo 100
    a(10) = a1(j10)

    a(9) = (1020 - a(10) - a(11) - a(12) - a(13) - a(14) - a(17) - a(25) - a(33) - a(41) - a(49)) / 2
    j9 = CInt(a(9)): If j9 <> a(9) Then GoTo 90
    If a(9) < a1(m1) Or a(9) > a1(m2) Then GoTo 90:
    If b1(a(9)) = 0 Then GoTo 90

    a(8) = 595 - a(9) - a(10) - a(11) - a(12) - a(13) - a(14)
    If a(8) < a1(m1) Or a(8) > a1(m2) Then GoTo 90:
    If b1(a(8)) = 0 Then GoTo 90

    a(7) = 170 - a(13): If a(7) < a1(m1) Or a(7) > a1(m2) Then GoTo 90:
    If b1(a(7)) = 0 Then GoTo 90
    
    a(6) = 170 - a(14): If a(6) < a1(m1) Or a(6) > a1(m2) Then GoTo 90:
    If b1(a(6)) = 0 Then GoTo 90
    
    a(5) = 170 - a(12): If a(5) < a1(m1) Or a(5) > a1(m2) Then GoTo 90:
    If b1(a(5)) = 0 Then GoTo 90

    a(4) = 170 - a(11): If a(4) < a1(m1) Or a(4) > a1(m2) Then GoTo 90:
    If b1(a(4)) = 0 Then GoTo 90
    
    a(3) = 170 - a(10): If a(3) < a1(m1) Or a(3) > a1(m2) Then GoTo 90:
    If b1(a(3)) = 0 Then GoTo 90

    If a(3) + a(11) + a(19) + a(27) + a(35) <> 352 Then GoTo 90
    
    a(2) = 170 - a(9): If a(2) < a1(m1) Or a(2) > a1(m2) Then GoTo 90:
    If b1(a(2)) = 0 Then GoTo 90
    
    a(1) = 170 - a(8): If a(1) < a1(m1) Or a(1) > a1(m2) Then GoTo 90:
    If b1(a(1)) = 0 Then GoTo 90

'                          Exclude solutions with identical numbers

                           GoSub 800: If fl1 = 0 Then GoTo 90

                           n9 = n9 + 1
                           GoSub 2650 'Print results (squares)
'                          GoSub 2645 'Print results (selected numbers)

90  b(c(10)) = 0: c(10) = 0
100 Next j10
    b(c(11)) = 0: c(11) = 0
110 Next j11
    b(c(12)) = 0: c(12) = 0
120 Next j12

    b(c(13)) = 0: c(13) = 0
130 b(c(14)) = 0: c(14) = 0
140 Next j14
    b(c(20)) = 0: c(20) = 0
200 b(c(21)) = 0: c(21) = 0
210 Next j21
    b(c(27)) = 0: c(27) = 0
270 b(c(28)) = 0: c(28) = 0
280 Next j28
    b(c(34)) = 0: c(34) = 0
340 b(c(35)) = 0: c(35) = 0
350 Next j35
    b(c(41)) = 0: c(41) = 0
410 b(c(42)) = 0: c(42) = 0
420 Next j42
    b(c(48)) = 0: c(48) = 0
480 b(c(49)) = 0: c(49) = 0
490 Next j49

    t2 = Timer
    
    t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
    y = MsgBox(t10, 0, "Routine MgcSqr7h")

End

'   Print results (selected numbers)

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

'   Print results (squares)

2650 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
     
'   Exclude solutions with identical numbers

800  fl1 = 1
     For j1 = 1 To 49
        a2 = a(j1)
        For j2 = (1 + j1) To 49
            If a2 = a(j2) Then fl1 = 0: Return
        Next j2
     Next j1
     Return

End Sub

Vorige Pagina About the Author