' Generates Semi Magic Squares of Subtraction (8 x 8)
' Part I, Magic Rows and Columns
' Tested with Office 365 under Windows 10
Sub CnstrSqrs8a()
Dim a(64), a0(8, 8), a1(8), a2(8), s(20)
Dim n(8, 2)
Dim a3(8, 8), a4(8, 8), a5(20), d1(8), d2(8)
Dim b(64), Line8(9)
Dim b1(9), b2(9)
y = MsgBox("Blocked", vbExclamation, "CnstrSqrs8a")
End
Sheets("Klad1").Select
n1 = 0: n9 = 0: k1 = 1: k2 = 1
ShtNm1 = "GenLns8"
ShtNm2 = "ScrSht8"
t1 = Timer
For j100 = 2 To 2
i2 = 1: i3 = 0
For i1 = 1 To 64:
i3 = i3 + 1: If i3 = 9 Then i3 = 1: i2 = i2 + 1
a0(i2, i3) = Sheets(ShtNm1).Cells(j100, i1)
Next i1
Res8 = Sheets(ShtNm1).Cells(j100, 65) 'Residuum
s1 = 260 'Magic Sum
Sheets(ShtNm2).Select
Cells.Select: Selection.ClearContents
Range("A1").Select
GoSub 500 ' Prepare Scratch Sheet
Sheets("Klad1").Select
For j1 = n(1, 1) To n(1, 2)
n10 = 8: Erase a
For i1 = 1 To 8
a1(i1) = Sheets(ShtNm2).Cells(j1, i1).Value
Next i1
For i1 = 1 To 8 ' First Line
a(i1) = a1(i1)
Next i1
For j2 = n(2, 1) To n(2, 2)
j300 = j2: GoSub 100: If fl1 = 0 Then GoTo 20
For j3 = n(3, 1) To n(3, 2)
j300 = j3: GoSub 100: If fl1 = 0 Then GoTo 30
For j4 = n(4, 1) To n(4, 2)
j300 = j4: GoSub 100: If fl1 = 0 Then GoTo 40
For j5 = n(5, 1) To n(5, 2)
j300 = j5: GoSub 100: If fl1 = 0 Then GoTo 50
For j6 = n(6, 1) To n(6, 2)
j300 = j6: GoSub 100: If fl1 = 0 Then GoTo 60
For j7 = n(7, 1) To n(7, 2)
j300 = j7: GoSub 100: If fl1 = 0 Then GoTo 70
For j8 = n(8, 1) To n(8, 2)
j300 = j8: GoSub 100: If fl1 = 0 Then GoTo 80
Nc9 = Nc9 + 1 'Unchecked (Diagonals)
n9 = n9 + 1: GoSub 750 'Print Semi Magic Squares
'Related number of Magic Squares Shown (n29)
5
n10 = n10 - 8
80 Next j8
n10 = n10 - 8
70 Next j7
n10 = n10 - 8
60 Next j6
n10 = n10 - 8
50 Next j5
n10 = n10 - 8
40 Next j4
n10 = n10 - 8
30 Next j3
n10 = n10 - 8
20 Next j2
n10 = n10 - 8
10 Next j1
1000 Next j100
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CnstrSqrs8a")
End
' Prepare Scratch Sheet
500
i90 = 0: n(1, 1) = 1
For i1 = 1 To 8
For i2 = 1 To 8
For i3 = 1 To 8
For i4 = 1 To 8
For i5 = 1 To 8
For i6 = 1 To 8
For i7 = 1 To 8
For i8 = 1 To 8
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)
If s11 <> s1 Then GoTo 580
Erase b, Line8
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)
q2 = 0
For q1 = 1 To 64
If b(q1) = q1 Then
q2 = q2 + 1: Line8(q2) = q1
End If
Next q1
s12 = Line8(8) - Line8(7) + Line8(6) - Line8(5) + Line8(4) - Line8(3) + Line8(2) - Line8(1)
If s12 <> Res8 Then GoTo 580
i90 = i90 + 1
Cells(i90, 1).Value = a0(1, i1)
Cells(i90, 2).Value = a0(2, i2)
Cells(i90, 3).Value = a0(3, i3)
Cells(i90, 4).Value = a0(4, i4)
Cells(i90, 5).Value = a0(5, i5)
Cells(i90, 6).Value = a0(6, i6)
Cells(i90, 7).Value = a0(7, i7)
Cells(i90, 8).Value = a0(8, i8)
Cells(i90, 10).Value = s12 ''j100
580 Next i8
570 Next i7
560 Next i6
550 Next i5
540 Next i4
530 Next i3
520 Next i2
n(i1, 2) = i90: If i1 <> 8 Then n(i1 + 1, 1) = i90 + 1
510 Next i1
n(8, 2) = i90
Return
' Construct Semi Magic Squares
100 fl1 = 1
For i1 = 1 To 8
a2(i1) = Sheets(ShtNm2).Cells(j300, i1).Value
Next i1
For i1 = 1 To 8
a20 = a2(i1)
For i2 = 1 To n10
If a20 = a(i2) Then fl1 = 0: Return
Next i2
Next i1
n10 = n10 + 8
i2 = 0
For i1 = n10 - 8 + 1 To n10
i2 = i2 + 1
a(i1) = a2(i2)
Next i1
Return
' Print results (Semi Magic Squares)
' Related number of Magic Squares Shown (n29)
750 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 9: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 9
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 = n29
Cells(k1, k2 + 8).Value = j100 'Generator Magic Lines
i3 = 0
For i1 = 1 To 8
For i2 = 1 To 8
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3) ''
Next i2
Next i1
Return
End Sub
