' Construct Order 17 Quadrant Magic Patterns (Bordered)
' Three 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 ChkPtrn17b()
Dim a1(120), b(289), c(289), b1(289)
y = MsgBox("Blocked", 0, "ChkPtrn17b")
End
k1 = 1: k2 = 1
m1 = 1:
Pr15 = 290: s1 = 2465
ShtNm1 = "CntrSqrs13" 'Input
GoSub 1500 'Read Border Variables and m2
Sheets("Klad1").Select
n9 = 0: Prefix1 = "P38"
For j100 = 5763 To 5821 '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
P38 38
''P39 39
''P45 45
''P51 51
''P134 134
''P135 135
''P138 138
''P139 139
If s(1) + s(2) + s(3) + s(4) <> 56 * s1 / 17 Then GoTo 1000
Erase b, c
For j271 = m1 To m2 'a(271)
If b(a1(j271)) = 0 Then b(a1(j271)) = a1(j271): c(271) = a1(j271) Else GoTo 2710
a(271) = a1(j271)
a(19) = Pr15 - a(271): If b(a(19)) = 0 Then b(a(19)) = a(19): c(19) = a(19) Else GoTo 190
For j265 = m1 To m2 'a(265)
If b(a1(j265)) = 0 Then b(a1(j265)) = a1(j265): c(265) = a1(j265) Else GoTo 2650
a(265) = a1(j265)
a(27) = Pr15 - a(265): If b(a(27)) = 0 Then b(a(27)) = a(27): c(27) = a(27) Else GoTo 270
a(169) = s1 - a(265) - a(271) - s(4)
If a(169) < a1(m1) Or a(169) > a1(m2) Then GoTo 1690
If b1(a(169)) = 0 Then GoTo 1690
If b(a(169)) = 0 Then b(a(169)) = a(169): c(169) = a(169) Else GoTo 1690
a(155) = Pr15 - a(169): If b(a(155)) = 0 Then b(a(155)) = a(155): c(155) = a(155) Else GoTo 1550
For j263 = m1 To m2 'a(263)
If b(a1(j263)) = 0 Then b(a1(j263)) = a1(j263): c(263) = a1(j263) Else GoTo 2630
a(263) = a1(j263)
a(25) = Pr15 - a(263): If b(a(25)) = 0 Then b(a(25)) = a(25): c(25) = a(25) Else GoTo 250
a(257) = -24 * s1 / 17 - a(263) - a(265) - a(271) + s(1) + s(2)
If a(257) < a1(m1) Or a(257) > a1(m2) Then GoTo 2570
If b1(a(257)) = 0 Then GoTo 2570
If b(a(257)) = 0 Then b(a(257)) = a(257): c(257) = a(257) Else GoTo 2570
a(33) = Pr15 - a(257): If b(a(33)) = 0 Then b(a(33)) = a(33): c(33) = a(33) Else GoTo 330
a(135) = -11 * s1 / 17 - a(263) - a(271) + s(1)
If a(135) < a1(m1) Or a(135) > a1(m2) Then GoTo 1350
If b1(a(135)) = 0 Then GoTo 1350
If b(a(135)) = 0 Then b(a(135)) = a(135): c(135) = a(135) Else GoTo 1350
a(121) = Pr15 - a(135): If b(a(121)) = 0 Then b(a(121)) = a(121): c(121) = a(121) Else GoTo 1210
GoSub 1300: If fl1 = 0 Then GoTo 5 'Check identical numbers (Back Check)
n9 = n9 + 1: GoSub 670 'Print Partial Completed Square
'' n9 = n9 + 1: GoSub 650 'Print Partial Completed Square (line format)
Erase a, b, c: GoTo 1000 'Print first square for j100
5
b(c(121)) = 0: c(121) = 0
1210 b(c(135)) = 0: c(135) = 0
1350
b(c(33)) = 0: c(33) = 0
330 b(c(257)) = 0: c(257) = 0
2570
b(c(25)) = 0: c(25) = 0
250 b(c(263)) = 0: c(263) = 0
2630 Next j263
b(c(155)) = 0: c(155) = 0
1550 b(c(169)) = 0: c(169) = 0
1690
b(c(27)) = 0: c(27) = 0
270 b(c(265)) = 0: c(265) = 0
2650 Next j265
b(c(19)) = 0: c(19) = 0
190 b(c(271)) = 0: c(271) = 0
2710 Next j271
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)
650
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
670 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
