About the Author

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

' Tested with Office 2007 under Windows 7

Sub SlctSqr4()

'   Preselection Center Squares

Dim s(4), a8(64)

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

m1 = 2: m2 = 160 ''13895
n9 = 1                        'Header Row

Sheets("Klad1").Select

For j1 = m1 To m2
s(1) = Sheets("Lines4").Cells(j1, 17).Value ' Mc4-1

For j2 = j1 + 1 To m2
s(2) = Sheets("Lines4").Cells(j2, 17).Value ' Mc4-2
If s(2) = s(1) Then GoTo 20

For j3 = j2 + 1 To m2
s(3) = Sheets("Lines4").Cells(j3, 17).Value ' Mc4-3
If s(3) = s(2) Or s(3) = s(1) Then GoTo 30

For j4 = j3 + 1 To m2
s(4) = Sheets("Lines4").Cells(j4, 17).Value ' Mc4-4

If s(4) = s(3) Or s(4) = s(2) Or s(4) = s(1) Then GoTo 40

If s(1) + s(4) <> s(2) + s(3) Then GoTo 40         'Check Mc4's
Pr10 = (s(1) + s(4)) / 4

If CInt(Pr10 / 2) <> Pr10 / 2 Then GoTo 40
If 5 * Pr10 - (s(3) + s(4)) < 0 Then GoTo 40       'Check Possibility Pr10

'   Exclude solutions with identical numbers a8()

    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 = s(1)
    Cells(n9, 6).Value = s(2)
    Cells(n9, 7).Value = s(3)
    Cells(n9, 8).Value = s(4)
    
    Cells(n9, 16).Value = Pr10
    Cells(n9, 16).Select

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

End

'   Exclude solutions with identical numbers a8()

850 fl1 = 1
    For i1 = 1 To 16
        a8(i1) = Sheets("Lines4").Cells(j1, i1).Value
        a8(i1 + 16) = Sheets("Lines4").Cells(j2, i1).Value
        a8(i1 + 32) = Sheets("Lines4").Cells(j3, i1).Value
        a8(i1 + 48) = Sheets("Lines4").Cells(j4, i1).Value
    Next i1
    For i1 = 1 To 64
        a20 = a8(i1): If a20 = 0 Then GoTo 860
        For i2 = (1 + i1) To 64
            If a20 = a8(i2) Then fl1 = 0: Return
        Next i2
860 Next i1
    Return

End Sub

About the Author