Vorige Pagina About the Author

' Constructs Prime Number Magic Squares of order 3

' Tested with Office 2007 under Windows 7

Sub CnstrSqrs3b()

Dim a2(3), b2(3), a(9), b(9), c(9)
   
y = MsgBox("Locked", vbExclamation, "Routine CnstrSqrs3b")
End

    n2 = 0: n9 = 0: k1 = 1: k2 = 1
    
    Sheets("Klad1").Select

    t1 = Timer
    
For j1 = 3 To 18

'   Read Magic Lines

    For j2 = 1 To 3: a2(j2) = Sheets("Solutions321").Cells(j1, j2).Value: Next j2
    For j2 = 1 To 3: b2(j2) = Sheets("Solutions321").Cells(j1, j2 + 4).Value: Next j2
    s1 = Sheets("Solutions321").Cells(j1, 11).Value
    
'   Construct squares a() and b()

    a(1) = a2(3):   a(2) = a2(1):   a(3) = a2(2):
    a(4) = a2(1):   a(5) = a2(2):   a(6) = a2(3):
    a(7) = a2(2):   a(8) = a2(3):   a(9) = a2(1):
    
    b(1) = b2(2):   b(2) = b2(3):   b(3) = b2(1):
    b(4) = b2(1):   b(5) = b2(2):   b(6) = b2(3):
    b(7) = b2(3):   b(8) = b2(1):   b(9) = b2(2):

'   Calculate Square c()

    For j2 = 1 To 9
        c(j2) = a(j2) + b(j2)
    Next j2

'   Print results

    GoSub 800: If fl1 = 0 Then GoTo 70

'   n9 = n9 + 1: GoSub 640  'Lines
    n9 = n9 + 1: GoSub 650  'Squares

70 Next j1
    
    t2 = Timer
    
    t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
    y = MsgBox(t10, vbInformation, "Routine CnstrSqrs3b")
    
End

'   Exclude solutions with identical numbers

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

'   Print results (selected numbers)

640 Cells(n9, 10).Select
    For i1 = 1 To 9
        Cells(n9, i1).Value = c(i1)
    Next i1
    Cells(n9, 10).Value = n9
    Return

'   Print results (squares)

650 n1 = n1 + 1
    If n1 = 5 Then
        n1 = 1: k1 = k1 + 4: k2 = 1
    Else
        If n9 > 1 Then k2 = k2 + 4
    End If
    
    Cells(k1, k2 + 1).Select
    Cells(k1, k2 + 1).Font.Color = -4165632
    Cells(k1, k2 + 1).Value = s1
    
    i3 = 0
    For i1 = 1 To 3
        For i2 = 1 To 3
            i3 = i3 + 1
            Cells(k1 + i1, k2 + i2).Value = c(i3)
        Next i2
    Next i1
    Return

End Sub

Vorige Pagina About the Author