About the Author

' Generates Inlaid Magic Squares of order 8 (Part 1)
' Sub Squares with Different Magic Sums

' Tested with Office 2007 under Windows 7

Sub SlctSqr3()

'   Preselection Center Squares

Dim a(4), a6(36)

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

m1 = 74: m2 = 200
n9 = 1                        'Header Row

Sheets("Klad1").Select

For j1 = m1 To m2
a(1) = Sheets("Lines3").Cells(j1, 5).Value

For j2 = j1 + 1 To m2
a(2) = Sheets("Lines3").Cells(j2, 5).Value
If a(2) = a(1) Then GoTo 20

For j3 = j2 + 1 To m2
a(3) = Sheets("Lines3").Cells(j3, 5).Value
If a(3) = a(2) Or a(3) = a(1) Then GoTo 30

For j4 = j3 + 1 To m2
a(4) = Sheets("Lines3").Cells(j4, 5).Value
If a(4) = a(3) Or a(4) = a(2) Or a(4) = a(1) Then GoTo 40

If a(1) + a(4) <> a(2) + a(3) Then GoTo 40        'Check Center Elements
Pr8 = a(1) + a(4)
If Pr8 < 798 Then GoTo 40                         'Check Minimum
If 4 * Pr8 - 3 * (a(3) + a(4)) < 0 Then GoTo 40   'Check Possibility Pr8

'   Exclude solutions with identical numbers a6()

    GoSub 850: If fl1 = 0 Then GoTo 40

    n9 = n9 + 1
    Cells(n9, 1).Value = j1
    Cells(n9, 2).Value = j2
    Cells(n9, 3).Value = j3
    Cells(n9, 4).Value = j4
    
    Cells(n9, 5).Value = a(1)
    Cells(n9, 6).Value = a(2)
    Cells(n9, 7).Value = a(3)
    Cells(n9, 8).Value = a(4)
    
    Cells(n9, 16).Value = Pr8

40 Next j4
30 Next j3
20 Next j2
10 Next j1

End

'   Exclude solutions with identical numbers a6()

850 fl1 = 1
    For i1 = 1 To 9
        a6(i1) = Sheets("Lines3").Cells(j1, i1).Value
        a6(i1 + 9) = Sheets("Lines3").Cells(j2, i1).Value
        a6(i1 + 18) = Sheets("Lines3").Cells(j3, i1).Value
        a6(i1 + 27) = Sheets("Lines3").Cells(j4, i1).Value
    Next i1
    For i1 = 1 To 36
        a20 = a6(i1): If a20 = 0 Then GoTo 860
        For i2 = (1 + i1) To 36
            If a20 = a6(i2) Then fl1 = 0: Return
        Next i2
860 Next i1
    Return

End Sub

About the Author