' Generates Magic Squares of order 9 for integers 1 thru 81, based on Matrix Operation
' Tested with Office 2007 under Windows 7
Sub MgcSqr9b()
y = MsgBox("Locked", vbCritical, "Routine MgcSqr9b")
End
Dim a(9, 9) 'Base Square
Dim t(9, 9) 'Transposed
Dim b(9, 9) 'Resulting Square B = 9 * T + A - 9
Sheets("Klad1").Select
t1 = Timer
n9 = 0: m2 = 9
For j1 = 1 To m2
For j2 = 1 To m2
If j2 = j1 Then GoTo 120
For j3 = 1 To m2
If j3 = j2 Or j3 = j1 Then GoTo 130
For j4 = 1 To m2
If j4 = j3 Or j4 = j2 Or j4 = j1 Then GoTo 140
For j5 = 1 To m2
If j5 = j4 Or j5 = j3 Or j5 = j2 Or j5 = j1 Then GoTo 150
For j6 = 1 To m2
If j6 = j5 Or j6 = j4 Or j6 = j3 Or j6 = j2 Or j6 = j1 Then GoTo 160
For j7 = 1 To m2
If j7 = j6 Or j7 = j5 Or j7 = j4 Or j7 = j3 Or j7 = j2 Or j7 = j1 Then GoTo 170
For j8 = 1 To m2
If j8 = j7 Or j8 = j6 Or j8 = j5 Or j8 = j4 Or j8 = j3 Or j8 = j2 Or j8 = j1 Then GoTo 180
For j9 = 1 To m2
If j9 = j8 Or j9 = j7 Or j9 = j6 Or j9 = j5 Or j9 = j4 Or j9 = j3 Or j9 = j2 Or j9 = j1 Then GoTo 190
GoSub 550 'Check 3 x 3 Squares with Columns summing to 15
If fl = 1 Then
GoSub 200 'Fill Matrix A
GoSub 300 'Transpose Matrix A
GoSub 400 'Calculate Matrix B = 9 * T + A - 9
n9 = n9 + 1
' GoSub 645 'Print results (Selected Numbers)
GoSub 650 'Print results (Squares)
End If
190 Next j9
180 Next j8
170 Next j7
160 Next j6
150 Next j5
140 Next j4
130 Next j3
120 Next j2
110 Next j1
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine MgcSqr9b")
End
' Fill Matrix A
200 a(1, 1) = j1: a(1, 2) = j2: a(1, 3) = j3: a(1, 4) = j7: a(1, 5) = j8: a(1, 6) = j9: a(1, 7) = j4: a(1, 8) = j5: a(1, 9) = j6 'Row 1
a(2, 1) = j4: a(2, 2) = j5: a(2, 3) = j6: a(2, 4) = j1: a(2, 5) = j2: a(2, 6) = j3: a(2, 7) = j7: a(2, 8) = j8: a(2, 9) = j9 'Row 2
a(3, 1) = j7: a(3, 2) = j8: a(3, 3) = j9: a(3, 4) = j4: a(3, 5) = j5: a(3, 6) = j6: a(3, 7) = j1: a(3, 8) = j2: a(3, 9) = j3 'Row 3
a(4, 1) = j1: a(4, 2) = j2: a(4, 3) = j3: a(4, 4) = j7: a(4, 5) = j8: a(4, 6) = j9: a(4, 7) = j4: a(4, 8) = j5: a(4, 9) = j6 'Row 4
a(5, 1) = j4: a(5, 2) = j5: a(5, 3) = j6: a(5, 4) = j1: a(5, 5) = j2: a(5, 6) = j3: a(5, 7) = j7: a(5, 8) = j8: a(5, 9) = j9 'Row 5
a(6, 1) = j7: a(6, 2) = j8: a(6, 3) = j9: a(6, 4) = j4: a(6, 5) = j5: a(6, 6) = j6: a(6, 7) = j1: a(6, 8) = j2: a(6, 9) = j3 'Row 6
a(7, 1) = j1: a(7, 2) = j2: a(7, 3) = j3: a(7, 4) = j7: a(7, 5) = j8: a(7, 6) = j9: a(7, 7) = j4: a(7, 8) = j5: a(7, 9) = j6 'Row 7
a(8, 1) = j4: a(8, 2) = j5: a(8, 3) = j6: a(8, 4) = j1: a(8, 5) = j2: a(8, 6) = j3: a(8, 7) = j7: a(8, 8) = j8: a(8, 9) = j9 'Row 8
a(9, 1) = j7: a(9, 2) = j8: a(9, 3) = j9: a(9, 4) = j4: a(9, 5) = j5: a(9, 6) = j6: a(9, 7) = j1: a(9, 8) = j2: a(9, 9) = j3 'Row 9
Return
' Transpose Matrix A
300 For i1 = 1 To m2
For i2 = 1 To m2
t(i1, i2) = a(i2, i1)
Next i2
Next i1
Return
' Calculate Matrix B = 9 * T + A - 9
400 For i1 = 1 To m2
For i2 = 1 To m2
b(i1, i2) = 9 * t(i1, i2) + a(i1, i2) - 9
Next i2
Next i1
Return
' Check 3 x 3 Squares with Columns summing to 15
550 c1 = j1 + j4 + j7: If c1 <> 15 Then fl = 0: Return
c2 = j2 + j5 + j8: If c2 <> 15 Then fl = 0: Return
c3 = j3 + j6 + j9: If c3 <> 15 Then fl = 0: Return
fl = 1
Return
' Print Results (Selected Numbers)
645 i3 = 0
For i1 = 1 To m2
For i2 = 1 To m2
i3 = i3 + 1
Cells(n9, i3).Value = b(i1, i2)
Next i2
Next i1
Return
' Print Results (Squares)
650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + m2 + 1: k2 = 0
Else
If n9 > 1 Then k2 = k2 + m2 + 1
End If
Cells(k1 + 1, k2 + 1).Select
If k1 > 0 Then
Cells(k1, k2 + 1).Font.Color = 12611584
Cells(k1, k2 + 1).Value = n9
End If
For i1 = 1 To m2
For i2 = 1 To m2
Cells(k1 + i1, k2 + i2).Value = b(i1, i2)
Next i2
Next i1
Return
End Sub
