' Generates Semi Magic Squares of Subtraction (10 x 10)
' Non Itterative (One Error)
' Tested with Office 365 under Windows 10
Sub SemiSqrs10()
Dim a(100), a0(10, 10), a1(10), a2(10)
Dim b(100), Line10(10)
y = MsgBox("Blocked", vbInformation, "SemiSqrs10")
End
n1 = 0: n9 = 0: k1 = 1: k2 = 15
s1 = 505
Res10 = 49
ShtNm1 = "GenLns10"
Sheets("Klad1").Select
t1 = Timer
For j100 = 1 To 286
i2 = 1: i3 = 0
For i1 = 1 To 100:
i3 = i3 + 1: If i3 = 11 Then i3 = 1: i2 = i2 + 1
a0(i2, i3) = Sheets(ShtNm1).Cells(j100, i1)
Next i1
i19 = 0
For j200 = 1 To 10
GoSub 500 'Search for Subtractive Lines
If fl1 = 0 Then Exit For 'Not Found
2000 Next j200
If j200 < 10 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 SemiSqrs10")
End
' Search for Subtractive Lines
500 fl1 = 1
For i1 = j200 To 10
For i2 = j200 To 10
For i3 = j200 To 10
For i4 = j200 To 10
For i5 = j200 To 10
For i6 = j200 To 10
For i7 = j200 To 10
For i8 = j200 To 10
For i9 = j200 To 10
For i10 = j200 To 10
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)
If s11 <> s1 Then GoTo 600
Erase b, Line10
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)
q2 = 0
For q1 = 1 To 100
If b(q1) = q1 Then
q2 = q2 + 1: Line10(q2) = q1
End If
Next q1
s12 = Line10(10) - Line10(9) + Line10(8) - Line10(7) + Line10(6) - Line10(5) + Line10(4) - Line10(3) + Line10(2) - Line10(1)
If s12 <> Res10 Then GoTo 600
' *** 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 = j100
Cells(i19, 12).Value = j200
Cells(i19, 12).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)
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)
For j1 = 1 To 10
a0(j1, j200) = a1(j1)
Next j1
Return
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 + 11: k2 = 15
Else
If n9 > 1 Then k2 = k2 + 11
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 10
For i2 = 1 To 10
Cells(k1 + i1, k2 + i2).Value = a0(i1, i2)
Next i2
Next i1
Return
End Sub
