' Generates Semi Magic Squares of Subtraction (11 x 11)
' Non Itterative (One Error)
' Tested with Office 365 under Windows 10
Sub SemiSqrs11()
Dim a(121), a0(11, 11), a1(11), a2(11)
Dim b(121), Line11(11)
y = MsgBox("Blocked", vbInformation, "SemiSqrs11")
End
n1 = 0: n9 = 0: k1 = 1: k2 = 16
s1 = 671
Res11 = 61
ShtNm1 = "GenLns11"
Sheets("Klad1").Select
t1 = Timer
For j100 = 1 To 95
i2 = 1: i3 = 0
For i1 = 1 To 121:
i3 = i3 + 1: If i3 = 12 Then i3 = 1: i2 = i2 + 1
a0(i2, i3) = Sheets(ShtNm1).Cells(j100, i1)
Next i1
i19 = 0
For j200 = 1 To 11
GoSub 500 'Search for Subtractive Lines
If fl1 = 0 Then Exit For 'Not Found
2000 Next j200
If j200 < 11 Then GoTo 1000
n9 = n9 + 1: GoSub 650
1000 Next j100
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine SemiSqrs11")
End
' Search for Subtractive Lines
500 fl1 = 1
For i1 = j200 To 11
For i2 = j200 To 11
For i3 = j200 To 11
For i4 = j200 To 11
For i5 = j200 To 11
For i6 = j200 To 11
For i7 = j200 To 11
For i8 = j200 To 11
For i9 = j200 To 11
For i10 = j200 To 11
For i11 = j200 To 11
s11 = a0(1, i1) + a0(2, i2) + a0(3, i3) + a0(4, i4) + a0(5, i5) + a0(6, i6) + a0(7, i7) + a0(8, i8) + a0(9, i9) + a0(10, i10) + a0(11, i11)
If s11 <> s1 Then GoTo 610
Erase b, Line11
b(a0(1, i1)) = a0(1, i1)
b(a0(2, i2)) = a0(2, i2)
b(a0(3, i3)) = a0(3, i3)
b(a0(4, i4)) = a0(4, i4)
b(a0(5, i5)) = a0(5, i5)
b(a0(6, i6)) = a0(6, i6)
b(a0(7, i7)) = a0(7, i7)
b(a0(8, i8)) = a0(8, i8)
b(a0(9, i9)) = a0(9, i9)
b(a0(10, i10)) = a0(10, i10)
b(a0(11, i11)) = a0(11, i11)
q2 = 0
For q1 = 1 To 121
If b(q1) = q1 Then
q2 = q2 + 1: Line11(q2) = q1
End If
Next q1
s12 = Line11(11) - Line11(10) + Line11(9) - Line11(8) + Line11(7) - Line11(6) + Line11(5) - Line11(4) + Line11(3) - Line11(2) + Line11(1)
If s12 <> Res11 Then GoTo 610
' Check Bimagic (Option)
''s12 = 0
''For q1 = 1 To 11
'' s12 = s12 + Line11(q1) ^ 2
''Next q1
''If s12 <> 54351 Then GoTo 610
' *** Test ***
i19 = i19 + 1
Cells(i19, 1).Value = a0(1, i1)
Cells(i19, 2).Value = a0(2, i2)
Cells(i19, 3).Value = a0(3, i3)
Cells(i19, 4).Value = a0(4, i4)
Cells(i19, 5).Value = a0(5, i5)
Cells(i19, 6).Value = a0(6, i6)
Cells(i19, 7).Value = a0(7, i7)
Cells(i19, 8).Value = a0(8, i8)
Cells(i19, 9).Value = a0(9, i9)
Cells(i19, 10).Value = a0(10, i10)
Cells(i19, 11).Value = a0(11, i11)
Cells(i19, 12).Value = j100
Cells(i19, 13).Value = j200
Cells(i19, 13).Select
' Swap Variables
a1(1) = a0(1, i1): a1(2) = a0(2, i2): a1(3) = a0(3, i3): a1(4) = a0(4, i4): a1(5) = a0(5, i5)
a1(6) = a0(6, i6): a1(7) = a0(7, i7): a1(8) = a0(8, i8): a1(9) = a0(9, i9): a1(10) = a0(10, i10)
a1(11) = a0(11, i11)
a0(1, i1) = a0(1, j200)
a0(2, i2) = a0(2, j200)
a0(3, i3) = a0(3, j200)
a0(4, i4) = a0(4, j200)
a0(5, i5) = a0(5, j200)
a0(6, i6) = a0(6, j200)
a0(7, i7) = a0(7, j200)
a0(8, i8) = a0(8, j200)
a0(9, i9) = a0(9, j200)
a0(10, i10) = a0(10, j200)
a0(11, i11) = a0(11, j200)
For j1 = 1 To 11
a0(j1, j200) = a1(j1)
Next j1
Return
610 Next i11
600 Next i10
590 Next i9
580 Next i8
570 Next i7
560 Next i6
550 Next i5
540 Next i4
530 Next i3
520 Next i2
510 Next i1
fl1 = 0
Return
' Print results (squares)
650 n2 = n2 + 1
If n2 = 3 Then
n2 = 1: k1 = k1 + 12: k2 = 16
Else
If n9 > 1 Then k2 = k2 + 12
End If
'' Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
Cells(k1, k2 + 2).Value = j100
Cells(k1, k2 + 3).Value = j200 - 1
i3 = 0
For i1 = 1 To 11
For i2 = 1 To 11
Cells(k1 + i1, k2 + i2).Value = a0(i1, i2)
Next i2
Next i1
Return
End Sub
