Vorige Pagina About the Author

' Generates Pan Magic Squares of order 8, Magic Sum 260, based on Matrix Operation

' Tested with Office 2007 under Windows 7

Sub MgcSqr8a()

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

    Dim A(8, 8)             'Base Square
    Dim R(8, 8)             'Rotated
    Dim B(8, 8)             'Resulting Square B = 8 * R + A - 8
  
    Sheets("Klad1").Select
    t1 = Timer

    n9 = 0: m2 = 8

For j1 = 1 To m2
    For j2 = 1 To m2
        If j2 = j1 Then GoTo 120
        For j3 = 1 To m2
            If j3 = j2 Or j3 = j1 Then GoTo 130
            For j4 = 1 To m2
                If j4 = j3 Or j4 = j2 Or j4 = j1 Then GoTo 140
                For j5 = 1 To m2
                    If j5 = j4 Or j5 = j3 Or j5 = j2 Or j5 = j1 Then GoTo 150
                    For j6 = 1 To m2
                        If j6 = j5 Or j6 = j4 Or j6 = j3 Or j6 = j2 Or j6 = j1 Then GoTo 160
                        For j7 = 1 To m2
                            If j7 = j6 Or j7 = j5 Or j7 = j4 Or j7 = j3 Or j7 = j2 Or j7 = j1 Then GoTo 170
                            For j8 = 1 To m2
                                If j8 = j7 Or j8 = j6 Or j8 = j5 Or j8 = j4 Or j8 = j3 Or j8 = j2 Or j8 = j1 Then GoTo 180
                                                                    
                                    GoSub 550       'Check sum of halfrow elements (=9)

                                    If fl = 1 Then
                                    
                                        GoSub 200   'Fill      Matrix A
                                        GoSub 300   'Rotate    Matrix A
                                        GoSub 400   'Calculate Matrix B = 8 * R + A - 8

                                        n9 = n9 + 1
'                                       GoSub 645   'Print results (Selected Numbers)
                                        GoSub 650   'Print results (Squares)
                                        
                                    End If

180                         Next j8
170                     Next j7
160                 Next j6
150             Next j5
140         Next j4
130     Next j3
120 Next j2
110 Next j1

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

End

'   Fill Matrix A

200 A(1, 1) = j1:      A(1, 2) = j2:      A(1, 3) = j3:      A(1, 4) = j4         'First 4 columns Row 1
    A(2, 1) = j5:      A(2, 2) = j6:      A(2, 3) = j7:      A(2, 4) = j8         'First 4 columns Row 2
    A(3, 1) = A(1, 1): A(3, 2) = A(1, 2): A(3, 3) = A(1, 3): A(3, 4) = A(1, 4)    'First 4 columns Row 3
    A(4, 1) = A(2, 1): A(4, 2) = A(2, 2): A(4, 3) = A(2, 3): A(4, 4) = A(2, 4)    'First 4 columns Row 4
    A(5, 1) = A(1, 1): A(5, 2) = A(1, 2): A(5, 3) = A(1, 3): A(5, 4) = A(1, 4)    'First 4 columns Row 5
    A(6, 1) = A(2, 1): A(6, 2) = A(2, 2): A(6, 3) = A(2, 3): A(6, 4) = A(2, 4)    'First 4 columns Row 6
    A(7, 1) = A(1, 1): A(7, 2) = A(1, 2): A(7, 3) = A(1, 3): A(7, 4) = A(1, 4)    'First 4 columns Row 7
    A(8, 1) = A(2, 1): A(8, 2) = A(2, 2): A(8, 3) = A(2, 3): A(8, 4) = A(2, 4)    'First 4 columns Row 8
    
    For j5 = 2 To 8                                                               'Fill remainder of square
        For j6 = 5 To 8
            A(j5, j6) = A(j5 - 1, j6 - 4)
        Next j6
    Next j5
    A(1, 5) = A(8, 1): A(1, 6) = A(8, 2): A(1, 7) = A(8, 3): A(1, 8) = A(8, 4)
    Return

'   Rotate Matrix A

300 For i1 = 1 To m2
        For i2 = 1 To m2
            R(i1, i2) = A(i2, 8 - i1 + 1)
        Next i2
    Next i1
    Return
    
'   Calculate Matrix B = 8 * R + A - 8

400 For i1 = 1 To m2
        For i2 = 1 To m2
            B(i1, i2) = 8 * R(i1, i2) + A(i1, i2) - 8
        Next i2
    Next i1
    Return

'   Check sum of halfrow elements (=9)

550 c1 = j1 + j5: If c1 <> 9 Then fl = 0: Return
    c2 = j2 + j6: If c2 <> 9 Then fl = 0: Return
    c3 = j3 + j7: If c3 <> 9 Then fl = 0: Return
    c4 = j4 + j8: If c4 <> 9 Then fl = 0: Return
    fl = 1
    Return

'   Print Results (Selected Numbers)

645 i3 = 0
    For i1 = 1 To m2
        For i2 = 1 To m2
            i3 = i3 + 1
            Cells(n9, i3).Value = B(i1, i2)
        Next i2
    Next i1
    Return

'   Print Results (Squares)

650 n2 = n2 + 1
    If n2 = 5 Then
        n2 = 1: k1 = k1 + m2 + 1: k2 = 0
    Else
        If n9 > 1 Then k2 = k2 + m2 + 1
    End If

    Cells(k1 + 1, k2 + 1).Select
        
    For i1 = 1 To m2
        For i2 = 1 To m2
            Cells(k1 + i1, k2 + i2).Value = B(i1, i2) 'B
        Next i2
    Next i1

    Return

End Sub

Vorige Pagina About the Author