' Construct Order 17 Quadrant Magic Patterns (Bordered)
' Five Parameter Solution
' Public Area's declared in Module4 (ChkPtrn17)
' Routines P01 ... P253 contain the equations describing the correponding pattern
' (not available in HTML)
' Tested with Office 365 under Windows 10
Sub ChkPtrn17c()
Dim a1(120), b(289), c(289), b1(289)
y = MsgBox("Blocked", 0, "ChkPtrn17c")
End
k1 = 1: k2 = 1
m1 = 1:
Pr15 = 290: s1 = 2465
ShtNm1 = "CntrSqrs13a" 'Input
GoSub 1500 'Read Border Variables and m2
Sheets("Klad1").Select
n9 = 0: Prefix1 = "P244"
For j100 = 5808 To 5821 ''5823 To 5828 'Option: Patterns in Center Square
''For j100 = 2 To 5761
Cells(1, 1).Value = j100
Erase a
For i1 = 1 To 289 'Read available Square(s)
a(i1) = Sheets(ShtNm1).Cells(j100, i1).Value
Next i1
TagNr1 = Sheets(ShtNm1).Cells(j100, 291).Value
' Select Pattern here
'' P112 112
'' P115 115
'' P116 116
'' P119 119
'' P120 120
'' P126 126
P244 244
If s(1) + s(2) + s(3) + s(4) <> 52 * s1 / 17 Then GoTo 1000
Erase b, c
For j269 = m1 To m2 'a(269)
If b(a1(j269)) = 0 Then b(a1(j269)) = a1(j269): c(269) = a1(j269) Else GoTo 2690
a(269) = a1(j269)
a(31) = Pr15 - a(269): If b(a(31)) = 0 Then b(a(31)) = a(31): c(31) = a(31) Else GoTo 310
For j267 = m1 To m2 'a(267)
If b(a1(j267)) = 0 Then b(a1(j267)) = a1(j267): c(267) = a1(j267) Else GoTo 2670
a(267) = a1(j267)
a(29) = Pr15 - a(267): If b(a(29)) = 0 Then b(a(29)) = a(29): c(29) = a(29) Else GoTo 290
For j261 = m1 To m2 'a(261)
If b(a1(j261)) = 0 Then b(a1(j261)) = a1(j261): c(261) = a1(j261) Else GoTo 2610
a(261) = a1(j261)
a(23) = Pr15 - a(261): If b(a(23)) = 0 Then b(a(23)) = a(23): c(23) = a(23) Else GoTo 230
a(259) = -22 * s1 / 17 - a(261) - a(267) - a(269) + s(1) + s(2)
If a(259) < a1(m1) Or a(259) > a1(m2) Then GoTo 2590
If b1(a(259)) = 0 Then GoTo 2590
If b(a(259)) = 0 Then b(a(259)) = a(259): c(259) = a(259) Else GoTo 2590
a(21) = Pr15 - a(259): If b(a(21)) = 0 Then b(a(21)) = a(21): c(21) = a(21) Else GoTo 210
For j237 = m1 To m2 'a(237)
If b(a1(j237)) = 0 Then b(a1(j237)) = a1(j237): c(237) = a1(j237) Else GoTo 2370
a(237) = a1(j237)
a(223) = Pr15 - a(237): If b(a(223)) = 0 Then b(a(223)) = a(223): c(223) = a(223) Else GoTo 2230
a(203) = 17 * s1 / 17 - a(237) - a(267) - a(269) - s(4)
If a(203) < a1(m1) Or a(203) > a1(m2) Then GoTo 2030
If b1(a(203)) = 0 Then GoTo 2030
If b(a(203)) = 0 Then b(a(203)) = a(203): c(203) = a(203) Else GoTo 2030
a(189) = Pr15 - a(203): If b(a(189)) = 0 Then b(a(189)) = a(189): c(189) = a(189) Else GoTo 1890
For j101 = m1 To m2 'a(101)
If b(a1(j101)) = 0 Then b(a1(j101)) = a1(j101): c(101) = a1(j101) Else GoTo 1010
a(101) = a1(j101)
a(87) = Pr15 - a(101): If b(a(87)) = 0 Then b(a(87)) = a(87): c(87) = a(87) Else GoTo 870
a(67) = 13 * s1 / 17 - a(101) + a(267) + a(269) - s(2)
If a(67) < a1(m1) Or a(67) > a1(m2) Then GoTo 670
If b1(a(67)) = 0 Then GoTo 670
If b(a(67)) = 0 Then b(a(67)) = a(67): c(67) = a(67) Else GoTo 670
a(53) = Pr15 - a(67): If b(a(53)) = 0 Then b(a(53)) = a(53): c(53) = a(53) Else GoTo 530
GoSub 1300: If fl1 = 0 Then GoTo 5 'Check identical numbers (Back Check)
'' n9 = n9 + 1: GoSub 1670 'Print Partial Completed Square
n9 = n9 + 1: GoSub 1650 'Print Partial Completed Square (line format)
Erase a, b, c: GoTo 1000 'Print first square for j100
5
b(c(53)) = 0: c(53) = 0
530 b(c(67)) = 0: c(67) = 0
670
b(c(87)) = 0: c(87) = 0
870 b(c(101)) = 0: c(101) = 0
1010 Next j101
b(c(189)) = 0: c(189) = 0
1890 b(c(203)) = 0: c(203) = 0
2030
b(c(223)) = 0: c(223) = 0
2230 b(c(237)) = 0: c(237) = 0
2370 Next j237
b(c(21)) = 0: c(21) = 0
210 b(c(259)) = 0: c(259) = 0
2590
b(c(23)) = 0: c(23) = 0
230 b(c(261)) = 0: c(261) = 0
2610 Next j261
b(c(29)) = 0: c(29) = 0
290 b(c(267)) = 0: c(267) = 0
2670 Next j267
b(c(31)) = 0: c(31) = 0
310 b(c(269)) = 0: c(269) = 0
2690 Next j269
1000 Next j100
End
' Read Border Variables (15 x 15)
1500 m2 = 56
a1(1) = 19: a1(2) = 20: a1(3) = 21: a1(4) = 22: a1(5) = 23: a1(6) = 24: a1(7) = 25: a1(8) = 26:
a1(9) = 27: a1(10) = 28: a1(11) = 29: a1(12) = 30: a1(13) = 31: a1(14) = 32: a1(15) = 33: a1(16) = 36:
a1(17) = 50: a1(18) = 53: a1(19) = 67: a1(20) = 70: a1(21) = 84: a1(22) = 87: a1(23) = 101: a1(24) = 104:
a1(25) = 118: a1(26) = 121: a1(27) = 135: a1(28) = 138: a1(29) = 152: a1(30) = 155: a1(31) = 169: a1(32) = 172:
a1(33) = 186: a1(34) = 189: a1(35) = 203: a1(36) = 206: a1(37) = 220: a1(38) = 223: a1(39) = 237: a1(40) = 240:
a1(41) = 254: a1(42) = 257: a1(43) = 258: a1(44) = 259: a1(45) = 260: a1(46) = 261: a1(47) = 262: a1(48) = 263:
a1(49) = 264: a1(50) = 265: a1(51) = 266: a1(52) = 267: a1(53) = 268: a1(54) = 269: a1(55) = 270: a1(56) = 271:
For i1 = 1 To m2
x = a1(i1): b1(x) = x
Next i1
Return
' Print partial completed squares (line format)
1650
For i1 = 1 To 289
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 290).Value = n9
Cells(n9, 291).Value = Prefix1 + "/" + TagNr1
Return
' Print partial completed squares
1670 n1 = n1 + 1
If n1 = 2 Then
n1 = 1: k1 = k1 + 18: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 18
End If
Cells(2, 1).Value = n9
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 17
For i2 = 1 To 17
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
' Check Identical Numbers a()
1300 fl1 = 1
For i1 = 1 To 289
a20 = a(i1): If a20 = 0 Then GoTo 1310
For i2 = (1 + i1) To 289
If a20 = a(i2) Then fl1 = 0: Return
Next i2
1310 Next i1
Return
End Sub
