|
|
About the Author |
' Filters Compact Magic Squares of order 9, based on defined properties, from collection {B}
' Tested with Office 2007 under Windows 7Sub 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 Sheets("Klad1").Cells(n50, j10).Value = a(j10) 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 Sheets("Klad1").Select j3 = 0 For j1 = 1 To 192 For j2 = 1 To 81 a(j2) = Sheets("Klad94a").Cells(j1, j2).Value 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
|
|
About the Author |