About the Author

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

' Tested with Office 2007 under Windows 7

Sub SlctSqr5()

'   Preselection Center Squares

Dim s(4), a10(100)

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

m1 = 5: m2 = 70
n9 = 1                        'Header Row

Sheets("Klad1").Select

For j1 = m1 To m2
s(1) = Sheets("Lines5").Cells(j1, 26).Value ' Mc5-1

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

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

For j4 = j3 + 1 To m2
s(4) = Sheets("Lines5").Cells(j4, 26).Value ' Mc5-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 MC5's
Pr12 = (s(1) + s(4)) / 5

If 6 * Pr12 - (s(3) + s(4)) < 0 Then GoTo 40       'Check Possibility Pr12

'   Exclude solutions with identical numbers a10()

    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 = Pr12

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

End

'   Exclude solutions with identical numbers a10()

850 fl1 = 1
    For i1 = 1 To 25
        a10(i1) = Sheets("Lines5").Cells(j1, i1).Value
        a10(i1 + 25) = Sheets("Lines5").Cells(j2, i1).Value
        a10(i1 + 50) = Sheets("Lines5").Cells(j3, i1).Value
        a10(i1 + 75) = Sheets("Lines5").Cells(j4, i1).Value
    Next i1
    For i1 = 1 To 100
        a20 = a10(i1): If a20 = 0 Then GoTo 860
        For i2 = (1 + i1) To 100
            If a20 = a10(i2) Then fl1 = 0: Return
        Next i2
860 Next i1
    Return

End Sub

About the Author