' Filters Compact Magic Squares of order 9, based on defined properties, from collection {B}

' Tested with Office 2007 under Windows 7

```Sub MgcSqr9c()

Dim a(81)

n1 = 2: n2 = 2                                'start row, column
n3 = 144                                      'number of squares to be transfered
n4 = 0: i4 = 0                                'current square

n50 = 0                                       '(start line - 1)

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

Sheets("Class09b").Select

For j3 = 1 To n3                              'Square nr j3 current

n4 = n4 + 1: n2 = 2 + (n4 - 1) * 10: i4 = 0

For j1 = n1 To n1 + 8                     'Row    within square j3
For j2 = n2 To n2 + 8                 'Column within square j3
i4 = i4 + 1
a(i4) = Sheets("Solutions933").Cells(j1, j2).Value         'load square
Next j2
Next j1

GoSub 50                                  'transfer square j3 to Base Square

If n4 = 4 Then n4 = 0: n1 = n1 + 10: n2 = 2

Next j3

End

'   transfer square j3 to Base Square

50  i4 = 0
For j1 = 2 To 10
For j2 = 2 To 10

i4 = i4 + 1
Cells(j1, j2).Value = a(i4)

Next j2
Next j1

y = MsgBox("Transferred " + CStr(j3), 0, "Test")

GoSub 300                                 'select and tranfer to solution sheet (Klad1)

Return

'   select and tranfer to solution sheet (Klad1)

300 n10 = 2: n20 = 2                          'start row, column
n30 = 648                                 'number of squares to be checked
n40 = 0: i40 = 0                          'current square

For j30 = 1 To n30                            'Square nr j30 current

n40 = n40 + 1: n20 = 2 + (n40 - 1) * 10: i40 = 0

For j10 = n10 To n10 + 8                  'Row    within square j30
For j20 = n20 To n20 + 8              'Column within square j30
i40 = i40 + 1
a(i40) = Cells(j10, j20).Value    'load square
Next j20
Next j10

fl1 = 1: GoSub 100                        'Check symmetric property
'    fl1 = 1: GoSub 200                       'Check third row/column sums to 123
'    fl1 = 1: GoSub 100: GoSub 200            'Check both properties

If fl1 = 1 Then                           'property thru
Cells(n10, n20).Select
n50 = n50 + 1
For j10 = 1 To 81
Next j10
End If

If n40 = 9 Then n40 = 0: n10 = n10 + 10: n20 = 2

Next j30

Return

'   Check symmetric property

100 If a(41) <> 41 Then fl1 = 0
If a(1) + a(81) <> 82 Then fl1 = 0
If a(11) + a(71) <> 82 Then fl1 = 0
If a(21) + a(61) <> 82 Then fl1 = 0
If a(31) + a(51) <> 82 Then fl1 = 0
If a(9) + a(73) <> 82 Then fl1 = 0
If a(17) + a(65) <> 82 Then fl1 = 0
If a(25) + a(57) <> 82 Then fl1 = 0
If a(33) + a(49) <> 82 Then fl1 = 0
Return

'   Check third row/column sums to 123

200 If a(1) + a(2) + a(3) <> 123 Then fl1 = 0
If a(4) + a(5) + a(6) <> 123 Then fl1 = 0
If a(7) + a(8) + a(9) <> 123 Then fl1 = 0
If a(10) + a(11) + a(12) <> 123 Then fl1 = 0
If a(13) + a(14) + a(15) <> 123 Then fl1 = 0
If a(16) + a(17) + a(18) <> 123 Then fl1 = 0
If a(19) + a(20) + a(21) <> 123 Then fl1 = 0
If a(22) + a(23) + a(24) <> 123 Then fl1 = 0
If a(25) + a(26) + a(27) <> 123 Then fl1 = 0
If a(28) + a(29) + a(30) <> 123 Then fl1 = 0
If a(31) + a(32) + a(33) <> 123 Then fl1 = 0
If a(34) + a(35) + a(36) <> 123 Then fl1 = 0
If a(37) + a(38) + a(39) <> 123 Then fl1 = 0
If a(40) + a(41) + a(42) <> 123 Then fl1 = 0
If a(43) + a(44) + a(45) <> 123 Then fl1 = 0
If a(46) + a(47) + a(48) <> 123 Then fl1 = 0
If a(49) + a(50) + a(51) <> 123 Then fl1 = 0
If a(52) + a(53) + a(54) <> 123 Then fl1 = 0
If a(55) + a(56) + a(57) <> 123 Then fl1 = 0
If a(58) + a(59) + a(60) <> 123 Then fl1 = 0
If a(61) + a(62) + a(63) <> 123 Then fl1 = 0
If a(64) + a(65) + a(66) <> 123 Then fl1 = 0
If a(67) + a(68) + a(69) <> 123 Then fl1 = 0
If a(70) + a(71) + a(72) <> 123 Then fl1 = 0
If a(73) + a(74) + a(75) <> 123 Then fl1 = 0
If a(76) + a(77) + a(78) <> 123 Then fl1 = 0
If a(79) + a(80) + a(81) <> 123 Then fl1 = 0

If a(1) + a(10) + a(19) <> 123 Then fl1 = 0
If a(28) + a(37) + a(46) <> 123 Then fl1 = 0
If a(55) + a(64) + a(73) <> 123 Then fl1 = 0
If a(2) + a(11) + a(20) <> 123 Then fl1 = 0
If a(29) + a(38) + a(47) <> 123 Then fl1 = 0
If a(56) + a(65) + a(74) <> 123 Then fl1 = 0
If a(3) + a(12) + a(21) <> 123 Then fl1 = 0
If a(30) + a(39) + a(48) <> 123 Then fl1 = 0
If a(57) + a(66) + a(75) <> 123 Then fl1 = 0
If a(4) + a(13) + a(22) <> 123 Then fl1 = 0
If a(31) + a(40) + a(49) <> 123 Then fl1 = 0
If a(58) + a(67) + a(76) <> 123 Then fl1 = 0
If a(5) + a(14) + a(23) <> 123 Then fl1 = 0
If a(32) + a(41) + a(50) <> 123 Then fl1 = 0
If a(59) + a(68) + a(77) <> 123 Then fl1 = 0
If a(6) + a(15) + a(24) <> 123 Then fl1 = 0
If a(33) + a(42) + a(51) <> 123 Then fl1 = 0
If a(60) + a(69) + a(78) <> 123 Then fl1 = 0
If a(7) + a(16) + a(25) <> 123 Then fl1 = 0
If a(34) + a(43) + a(52) <> 123 Then fl1 = 0
If a(61) + a(70) + a(79) <> 123 Then fl1 = 0
If a(8) + a(17) + a(26) <> 123 Then fl1 = 0
If a(35) + a(44) + a(53) <> 123 Then fl1 = 0
If a(62) + a(71) + a(80) <> 123 Then fl1 = 0
If a(9) + a(18) + a(27) <> 123 Then fl1 = 0
If a(36) + a(45) + a(54) <> 123 Then fl1 = 0
If a(63) + a(72) + a(81) <> 123 Then fl1 = 0

Return

End Sub
```

' Transfers results to Magic Squares (9 x 9)

```Sub Transfer91()

y = MsgBox("Blocked", vbCritical, "Transfer91")
End

Dim a(81)

n2 = 0: n9 = 0

j3 = 0
For j1 = 1 To 192

For j2 = 1 To 81
Next j2

n9 = n9 + 1: GoSub 2650

Next j1

End

'   Print results (squares)

2650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 10: k2 = 0
Else
If n9 > 1 Then k2 = k2 + 10
End If
Cells(k1 + 1, k2 + 1).Select

i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1

Return

End Sub
```