' Constructs Order 13 Simple Magic Squares, Consecutive Prime Numbers
' Based on Semi Magic Squares
' Tested with Office 365 under Windows 10
Sub CnstrSqrs13b()
Dim a(169), a1(13), a2(13)
Dim a3(13, 13), a4(13, 13), a5(26), d1(13), d2(13)
y = MsgBox("Blocked", vbInformation, "CnstrSqrs13b")
End
Sheets("Klad1").Select
n1 = 0: n9 = 0: k1 = 1: k2 = 1
ShtNm1 = "SemiLns13"
ShtNm2 = "ScrSht13"
t1 = Timer
' Read Semi Bimagic Squares
For j100 = 1 To 1 ''10
Cells(1, 1).Value = j100
For i1 = 1 To 169
a(i1) = Sheets(ShtNm1).Cells(j100, i1).Value
Next i1
s1 = Sheets(ShtNm1).Cells(j100, 170).Value
' Check Possible Diagonals
GoSub 200: If fl1 = 0 Then GoTo 5 'Write Sets 'ScrSht13'
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 CnstrSqrs13b")
End
' Check Possibility Diagonals
200 fl1 = 1
i2 = 1: i3 = 0
For i1 = 1 To 169:
i3 = i3 + 1: If i3 = 14 Then i3 = 1: i2 = i2 + 1
a3(i2, i3) = a(i1)
Next i1
i31 = 0
For i11 = 1 To 2 ''13 '*** Reduced Collection ***
y = MsgBox("i11 = " + CStr(i11), 0, "Test")
For i12 = 1 To 13
If i12 = i11 Then GoTo 220
For i13 = 1 To 13
If i13 = i11 Or i13 = i12 Then GoTo 230
For i14 = 1 To 13
If i14 = i11 Or i14 = i12 Or i14 = i13 Then GoTo 240
For i15 = 1 To 13
If i15 = i11 Or i15 = i12 Or i15 = i13 Or i15 = i14 Then GoTo 250
For i16 = 1 To 13
If i16 = i11 Or i16 = i12 Or i16 = i13 Or i16 = i14 Or i16 = i15 Then GoTo 260
For i17 = 1 To 13
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 13
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 13
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 13
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
For i21 = 1 To 13
If i21 = i11 Or i21 = i12 Or i21 = i13 Or i21 = i14 Or i21 = i15 Or i21 = i16 Or i21 = i17 Then GoTo 330
If i21 = i18 Or i21 = i19 Or i21 = i20 Then GoTo 330
For i22 = 1 To 13
If i22 = i11 Or i22 = i12 Or i22 = i13 Or i22 = i14 Or i22 = i15 Or i22 = i16 Or i22 = i17 Then GoTo 340
If i22 = i18 Or i22 = i19 Or i22 = i20 Or i22 = i21 Then GoTo 340
For i23 = 1 To 13
If i23 = i11 Or i23 = i12 Or i23 = i13 Or i23 = i14 Or i23 = i15 Or i23 = i16 Or i23 = i17 Then GoTo 350
If i23 = i18 Or i23 = i19 Or i23 = i20 Or i23 = i21 Or i23 = i22 Then GoTo 350
s13 = 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) + a3(11, i21) + a3(12, i22) + a3(13, i23)
If s13 <> s1 Then GoTo 350
i31 = i31 + 1
Sheets(ShtNm2).Cells(i31, 11).Value = a3(1, i11)
Sheets(ShtNm2).Cells(i31, 12).Value = a3(2, i12)
Sheets(ShtNm2).Cells(i31, 13).Value = a3(3, i13)
Sheets(ShtNm2).Cells(i31, 14).Value = a3(4, i14)
Sheets(ShtNm2).Cells(i31, 15).Value = a3(5, i15)
Sheets(ShtNm2).Cells(i31, 16).Value = a3(6, i16)
Sheets(ShtNm2).Cells(i31, 17).Value = a3(7, i17)
Sheets(ShtNm2).Cells(i31, 18).Value = a3(8, i18)
Sheets(ShtNm2).Cells(i31, 19).Value = a3(9, i19)
Sheets(ShtNm2).Cells(i31, 20).Value = a3(10, i20)
Sheets(ShtNm2).Cells(i31, 21).Value = a3(11, i21)
Sheets(ShtNm2).Cells(i31, 22).Value = a3(12, i22)
Sheets(ShtNm2).Cells(i31, 23).Value = a3(13, i23)
If i11 = 1 And i31 = 100 Then GoTo 210 '*** Reduced Collection ***
If i11 = 2 And i31 = 1500 Then GoTo 210
350 Next i23
340 Next i22
330 Next i21
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 i31 < 2 Then fl1 = 0: Return
n19 = 0
For j11 = 1 To i31 '*** Define Alternative Starting Point j11 ***
'*** As Required ***
n20 = 13: Erase a5
For i1 = 1 To 13
a1(i1) = Sheets(ShtNm2).Cells(j11, i1 + 10).Value
Next i1
For i1 = 1 To 13 'First Line
a5(i1) = a1(i1)
Next i1
For j12 = j11 + 1 To i31
j300 = j12: GoSub 300: If fl2 = 0 Then GoTo 120
' Write Set Diagonals to 'ScrSht8'
For i1 = 1 To 2
n19 = n19 + 1: If n19 > 15000 Then Return
For i2 = 1 To 13
Sheets(ShtNm2).Cells(n19, i2 + 26).Value = a5(i2 + (i1 - 1) * 13)
Next i2
Sheets(ShtNm2).Cells(n19, 14 + 26).Value = i1
Next i1
n20 = n20 - 13
120 Next j12
n20 = n20 - 13
110 Next j11
If n19 < 2 Then fl1 = 0
Return
' Construct Magic Set Diagonals
300 fl2 = 1
For i1 = 1 To 13
a2(i1) = Sheets(ShtNm2).Cells(j300, i1 + 10).Value
Next i1
n22 = 0
For i1 = 1 To 13
a20 = a2(i1)
For i2 = 1 To n20
If a20 = a5(i2) Then n22 = n22 + 1: i21 = i1: i122 = i2
Next i2
Next i1
If n22 <> 1 Then fl2 = 0: Return 'Only one common allowed
' One Element Common (Center) ok
n20 = n20 + 13: i122 = i122 + 13
i2 = 0
For i1 = n20 - 13 + 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 13
d1(i1) = Sheets(ShtNm2).Cells(j20, i1 + 26).Value
d2(i1) = Sheets(ShtNm2).Cells(j20 + 1, i1 + 26).Value
Next i1
Erase a4
For i1 = 1 To 13
For i2 = 1 To 13
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 13 'rows
n21 = 0: i41 = 0: i42 = 0
For i2 = 1 To 13 'clmns
If a4(i1, i2) <> 0 Then
n21 = n21 + 1
If n21 = 1 Then i41 = i2 Else i42 = i2
End If
Next i2
If i41 = 0 Or i42 = 0 Then GoTo 460
For i3 = i1 + 1 To 13
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
460 Next i1
Return
' Print Semi Magic Squares
' Required Transformation Highlighted
650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 14: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 14
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 13
For i2 = 1 To 13
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 + 14: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 14
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 13
For i2 = 1 To 13
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
