' Generates Semi Magic Squares of Subtraction (12 x 12)
' Non Itterative
' Tested with Office 365 under Windows 10
Sub SemiSqrs12(x)
Dim a(144), a0(12, 12), a1(12), a2(12)
Dim b(144), Line12(12)
y = MsgBox("Blocked", vbInformation, "SemiSqrs12")
End
n1 = 0: n9 = 0: k1 = 1: k2 = 16
s1 = 870
Res12 = 72
ShtNm1 = "GenLns12"
Sheets("Klad1").Select
t1 = Timer
For j100 = 1 To 196
Cells(1, 14).Value = j100
i2 = 1: i3 = 0
For i1 = 1 To 144:
i3 = i3 + 1: If i3 = 13 Then i3 = 1: i2 = i2 + 1
a0(i2, i3) = Sheets(ShtNm1).Cells(j100, i1)
Next i1
i19 = 0
For j200 = 1 To 12
GoSub 500 'Search for Subtractive Lines
If fl1 = 0 Then Exit For 'Not Found
2000 Next j200
If j200 < 13 Then GoTo 1000 'zero errors
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 SemiSqrs12")
End
' Search for Subtractive Lines
500 fl1 = 1
For i1 = j200 To 12
For i2 = j200 To 12
For i3 = j200 To 12
For i4 = j200 To 12
For i5 = j200 To 12
For i6 = j200 To 12
For i7 = j200 To 12
For i8 = j200 To 12
For i9 = j200 To 12
For i10 = j200 To 12
For i11 = j200 To 12
For i12 = j200 To 12
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) + a0(12, i12)
If s11 <> s1 Then GoTo 620
Erase b, Line12
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)
b(a0(12, i12)) = a0(12, i12)
q2 = 0
For q1 = 1 To 144
If b(q1) = q1 Then
q2 = q2 + 1: Line12(q2) = q1
End If
Next q1
s12 = Line12(12) - Line12(11) + Line12(10) - Line12(9) + Line12(8) - Line12(7) +
+ Line12(6) - Line12(5) + Line12(4) - Line12(3) + Line12(2) - Line12(1)
If s12 <> Res12 Then GoTo 620
' *** 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 = a0(12, i12)
Cells(i19, 13).Value = j100
Cells(i19, 14).Value = j200
Cells(i19, 14).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): a1(12) = a0(12, i12)
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)
a0(12, i12) = a0(12, j200)
For j1 = 1 To 12
a0(j1, j200) = a1(j1)
Next j1
Return
620 Next i12
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 + 13: k2 = 16
Else
If n9 > 1 Then k2 = k2 + 13
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 12
For i2 = 1 To 12
Cells(k1 + i1, k2 + i2).Value = a0(i1, i2)
Next i2
Next i1
Return
End Sub
