' Constructs Order 10 Simple Magic Squares, Integers 1 ... 100
' Based on Semi Magic Squares
' Tested with Office 365 under Windows 10
Sub CnstrSqrs10()
Dim a(100), a1(10), a2(10)
Dim a3(10, 10), a4(10, 10), a5(20), d1(10), d2(10)
y = MsgBox("Blocked", vbInformation, "CnstrSqrs10")
End
Sheets("Klad1").Select
n1 = 0: n9 = 0: k1 = 1: k2 = 1
ShtNm1 = "SemiLns10"
ShtNm2 = "ScrSht10"
t1 = Timer
' Read Semi Magic Squares
For j100 = 16 To 16 ''23
Cells(1, 1).Value = j100
For i1 = 1 To 100
a(i1) = Sheets(ShtNm1).Cells(j100, i1).Value
Next i1
s1 = Sheets(ShtNm1).Cells(j100, 101).Value
' Check Possible Diagonals
GoSub 200: If fl1 = 0 Then GoTo 5 'Write Sets 'ScrSht10'
GoSub 400: If n29 = 0 Then GoTo 5 'Check Valid Sets
'' n9 = n9 + 1: GoSub 750 'Print results (squares)
''End
5
1000 Next j100
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CnstrSqrs10b")
End
' Check Possibility Diagonals
200 fl1 = 1
i2 = 1: i3 = 0
For i1 = 1 To 100:
i3 = i3 + 1: If i3 = 11 Then i3 = 1: i2 = i2 + 1
a3(i2, i3) = a(i1)
Next i1
i21 = 0
For i11 = 1 To 10
For i12 = 1 To 10
If i12 = i11 Then GoTo 220
For i13 = 1 To 10
If i13 = i11 Or i13 = i12 Then GoTo 230
For i14 = 1 To 10
If i14 = i11 Or i14 = i12 Or i14 = i13 Then GoTo 240
For i15 = 1 To 10
If i15 = i11 Or i15 = i12 Or i15 = i13 Or i15 = i14 Then GoTo 250
For i16 = 1 To 10
If i16 = i11 Or i16 = i12 Or i16 = i13 Or i16 = i14 Or i16 = i15 Then GoTo 260
For i17 = 1 To 10
If i17 = i11 Or i17 = i12 Or i17 = i13 Or i17 = i14 Or i17 = i15 Or i17 = i16 Then GoTo 270
For i18 = 1 To 10
If i18 = i11 Or i18 = i12 Or i18 = i13 Or i18 = i14 Or i18 = i15 Or i18 = i16 Or i18 = i17 Then GoTo 280
For i19 = 1 To 10
If i19 = i11 Or i19 = i12 Or i19 = i13 Or i19 = i14 Or i19 = i15 Or i19 = i16 Or i19 = i17 Then GoTo 290
If i19 = i18 Then GoTo 290
For i20 = 1 To 10
If i20 = i11 Or i20 = i12 Or i20 = i13 Or i20 = i14 Or i20 = i15 Or i20 = i16 Or i20 = i17 Then GoTo 320
If i20 = i18 Or i20 = i19 Then GoTo 320
s11 = a3(1, i11) + a3(2, i12) + a3(3, i13) + a3(4, i14) + a3(5, i15) + a3(6, i16) + a3(7, i17) +
+ a3(8, i18) + a3(9, i19) + a3(10, i20)
If s11 <> s1 Then GoTo 320
i21 = i21 + 1
Sheets(ShtNm2).Cells(i21, 11).Value = a3(1, i11)
Sheets(ShtNm2).Cells(i21, 12).Value = a3(2, i12)
Sheets(ShtNm2).Cells(i21, 13).Value = a3(3, i13)
Sheets(ShtNm2).Cells(i21, 14).Value = a3(4, i14)
Sheets(ShtNm2).Cells(i21, 15).Value = a3(5, i15)
Sheets(ShtNm2).Cells(i21, 16).Value = a3(6, i16)
Sheets(ShtNm2).Cells(i21, 17).Value = a3(7, i17)
Sheets(ShtNm2).Cells(i21, 18).Value = a3(8, i18)
Sheets(ShtNm2).Cells(i21, 19).Value = a3(9, i19)
Sheets(ShtNm2).Cells(i21, 20).Value = a3(10, i20)
320 Next i20
290 Next i19
280 Next i18
270 Next i17
260 Next i16
250 Next i15
240 Next i14
230 Next i13
220 Next i12
210 Next i11
If i21 < 2 Then fl1 = 0: Return
n19 = 0
For j11 = 1 To i21
n20 = 10: Erase a5
For i1 = 1 To 10
a1(i1) = Sheets(ShtNm2).Cells(j11, i1 + 10).Value
Next i1
For i1 = 1 To 10 'First Line
a5(i1) = a1(i1)
Next i1
For j12 = j11 + 1 To i21
j300 = j12: GoSub 300: If fl2 = 0 Then GoTo 120
' Write Set Diagonals to 'ScrSht10'
For i1 = 1 To 2
n19 = n19 + 1: If n19 > 5000 Then Return
For i2 = 1 To 10
Sheets(ShtNm2).Cells(n19, i2 + 20).Value = a5(i2 + (i1 - 1) * 10)
Next i2
Sheets(ShtNm2).Cells(n19, 11 + 20).Value = i1
Next i1
n20 = n20 - 10
120 Next j12
n20 = n20 - 10
110 Next j11
If n19 < 2 Then fl1 = 0
Return
' Construct Magic Set Diagonals
300 fl2 = 1
For i1 = 1 To 10
a2(i1) = Sheets(ShtNm2).Cells(j300, i1 + 10).Value
Next i1
For i1 = 1 To 10
a20 = a2(i1)
For i2 = 1 To n20
If a20 = a5(i2) Then fl2 = 0: Return
Next i2
Next i1
n20 = n20 + 10
i2 = 0
For i1 = n20 - 10 + 1 To n20
i2 = i2 + 1
a5(i1) = a2(i2)
Next i1
Return
' Read Diagonals for Final Check
400
n29 = 0
For j20 = 1 To n19 - 1 Step 2
For i1 = 1 To 10
d1(i1) = Sheets(ShtNm2).Cells(j20, i1 + 20).Value
d2(i1) = Sheets(ShtNm2).Cells(j20 + 1, i1 + 20).Value
Next i1
Erase a4
For i1 = 1 To 10
For i2 = 1 To 10
If a3(i1, i2) = d1(i1) Then a4(i1, i2) = 1
If a3(i1, i2) = d2(i1) Then a4(i1, i2) = 2
Next i2
Next i1
GoSub 450 'Check if transformation is possible
If fl1 = 1 Then
n29 = n29 + 1
' Print Semi Magic Squares
' Required Transformation Highlighted
n9 = n9 + 1: GoSub 650
End If
Next j20
Return
' Check if transformation is possible
450 fl1 = 1
For i1 = 1 To 10 'rows
n21 = 0
For i2 = 1 To 10 'clmns
If a4(i1, i2) <> 0 Then
n21 = n21 + 1
If n21 = 1 Then i41 = i2 Else i42 = i2
End If
Next i2
For i3 = i1 + 1 To 10
If a4(i3, i41) = 0 And a4(i3, i42) = 0 Then
'continue
Else
If a4(i3, i41) = a4(i1, i42) And a4(i3, i42) = a4(i1, i41) Then
Exit For 'ok
Else
fl1 = 0: Return 'no match
End If
End If
Next i3
Next i1
Return
' Print Semi Magic Squares
' Required Transformation Highlighted
650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 11: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 11
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 10
For i2 = 1 To 10
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Select Case a4(i1, i2)
Case 1
Range(Cells(k1 + i1, k2 + i2), Cells(k1 + i1, k2 + i2)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
Case 2
Range(Cells(k1 + i1, k2 + i2), Cells(k1 + i1, k2 + i2)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Case 0
End Select
Next i2
Next i1
Return
' Print results (squares)
750 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 11: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 11
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 10
For i2 = 1 To 10
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
