' Generates Order 11 Border / Diamond Combinations with 4 x 5 Even Corner Numbers
' Suitable for Concentric Lozenge Squares of order 15
' Tested with Office 365 under Windows 10
Sub Priem11h()
Dim a1(225), a(225), a11(121), a15(225), b(225), b1(225), c(121)
y = MsgBox("Locked", vbCritical, "Routine Priem11h")
End
n5 = 0: n9 = 0: n10 = 0: k1 = 1: k2 = 1
Sheets("Klad1").Select
t1 = Timer
m1 = 1: m2 = 225: s1 = 1243: p2 = 226
For i1 = 1 To m2
a1(i1) = i1: b1(i1) = i1
Next i1
For j100 = 2 To 2
' Read Diamond Inlay / Border 9 Combinations
Erase a
For i1 = 1 To 225
a(i1) = Sheets("DiaLns8").Cells(j100, i1):
If a(i1) <> 0 Then b(a(i1)) = a(i1)
Next i1
' Store Center Square in a11()
Erase a11
a11(4) = a(36): a11(5) = a(37): a11(6) = a(38): a11(7) = a(39): a11(8) = a(40):
a11(13) = a(49): a11(14) = a(50): a11(15) = a(51): a11(16) = a(52): a11(17) = a(53): a11(18) = a(54):
a11(19) = a(55): a11(20) = a(56): a11(21) = a(57):
a11(24) = a(64): a11(25) = a(65): a11(26) = a(66): a11(27) = a(67): a11(28) = a(68): a11(29) = a(69):
a11(30) = a(70): a11(31) = a(71): a11(32) = a(72):
a11(34) = a(78): a11(35) = a(79): a11(36) = a(80): a11(37) = a(81): a11(38) = a(82): a11(39) = a(83):
a11(40) = a(84): a11(41) = a(85): a11(42) = a(86): a11(43) = a(87): a11(44) = a(88):
a11(45) = a(93): a11(46) = a(94): a11(47) = a(95): a11(48) = a(96): a11(49) = a(97): a11(50) = a(98):
a11(51) = a(99): a11(52) = a(100): a11(53) = a(101): a11(54) = a(102): a11(55) = a(103):
a11(56) = a(108): a11(57) = a(109): a11(58) = a(110): a11(59) = a(111): a11(60) = a(112): a11(61) = a(113):
a11(62) = a(114): a11(63) = a(115): a11(64) = a(116): a11(65) = a(117): a11(66) = a(118):
a11(67) = a(123): a11(68) = a(124): a11(69) = a(125): a11(70) = a(126): a11(71) = a(127): a11(72) = a(128):
a11(73) = a(129): a11(74) = a(130): a11(75) = a(131): a11(76) = a(132): a11(77) = a(133):
a11(78) = a(138): a11(79) = a(139): a11(80) = a(140): a11(81) = a(141): a11(82) = a(142): a11(83) = a(143):
a11(84) = a(144): a11(85) = a(145): a11(86) = a(146): a11(87) = a(147): a11(88) = a(148):
a11(90) = a(154): a11(91) = a(155): a11(92) = a(156): a11(93) = a(157): a11(94) = a(158): a11(95) = a(159):
a11(96) = a(160): a11(97) = a(161): a11(98) = a(162):
a11(101) = a(169): a11(102) = a(170): a11(103) = a(171): a11(104) = a(172): a11(105) = a(173): a11(106) = a(174):
a11(107) = a(175): a11(108) = a(176): a11(109) = a(177):
a11(114) = a(186): a11(115) = a(187): a11(116) = a(188): a11(117) = a(189): a11(118) = a(190):
' Complete Border (only even numbers available)
For j119 = m1 To m2 'a11(119)
If b(a1(j119)) = 0 Then b(a1(j119)) = a1(j119): c(119) = a1(j119) Else GoTo 1190
a11(119) = a1(j119)
a11(9) = p2 - a11(119): If b(a11(9)) = 0 Then b(a11(9)) = a11(9): c(9) = a11(9) Else GoTo 90
For j120 = j119 + 1 To m2 'a11(120)
If b(a1(j120)) = 0 Then b(a1(j120)) = a1(j120): c(120) = a1(j120) Else GoTo 1200
a11(120) = a1(j120)
a11(10) = p2 - a11(120): If b(a11(10)) = 0 Then b(a11(10)) = a11(10): c(10) = a11(10) Else GoTo 100
For j121 = j120 + 1 To m2 'a11(121)
If b(a1(j121)) = 0 Then b(a1(j121)) = a1(j121): c(121) = a1(j121) Else GoTo 1210
a11(121) = a1(j121)
a11(1) = p2 - a11(121): If b(a11(1)) = 0 Then b(a11(1)) = a11(1): c(1) = a11(1) Else GoTo 10
For j112 = m2 / 2 To m2 'a11(112)
If b(a1(j112)) = 0 Then b(a1(j112)) = a1(j112): c(112) = a1(j112) Else GoTo 1120
a11(112) = a1(j112)
a11(2) = p2 - a11(112): If b(a11(2)) = 0 Then b(a11(2)) = a11(2): c(2) = a11(2) Else GoTo 20
For j113 = j112 + 1 To m2 'a11(113)
If b(a1(j113)) = 0 Then b(a1(j113)) = a1(j113): c(113) = a1(j113) Else GoTo 1130
a11(113) = a1(j113)
a11(3) = p2 - a11(113): If b(a11(3)) = 0 Then b(a11(3)) = a11(3): c(3) = a11(3) Else GoTo 30
a11(111) = s1 - a11(112) - a11(113) - a11(114) - a11(115) - a11(116) - a11(117) - a11(118) - a11(119) - a11(120) - a11(121)
If a11(111) < a1(m1) Or a11(111) > a1(m2) Then GoTo 1110:
If b1(a11(111)) = 0 Then GoTo 1110
If b(a11(111)) = 0 Then b(a11(111)) = a11(111): c(111) = a11(111) Else GoTo 1110
a11(11) = p2 - a11(111): If b(a11(11)) = 0 Then b(a11(11)) = a11(11): c(11) = a11(11) Else GoTo 110
For j110 = m2 / 2 To m2 'a11(110)
If b(a1(j110)) = 0 Then b(a1(j110)) = a1(j110): c(110) = a1(j110) Else GoTo 1100
a11(110) = a1(j110)
a11(100) = p2 - a11(110): If b(a11(100)) = 0 Then b(a11(100)) = a11(100): c(100) = a11(100) Else GoTo 1000
For j99 = j110 + 1 To m2 'a11(99)
If b(a1(j99)) = 0 Then b(a1(j99)) = a1(j99): c(99) = a1(j99) Else GoTo 990
a11(99) = a1(j99)
a11(89) = p2 - a11(99): If b(a11(89)) = 0 Then b(a11(89)) = a11(89): c(89) = a11(89) Else GoTo 890
For j33 = j99 + 1 To m2 'a11(33)
If b(a1(j33)) = 0 Then b(a1(j33)) = a1(j33): c(33) = a1(j33) Else GoTo 330
a11(33) = a1(j33)
a11(23) = p2 - a11(33): If b(a11(23)) = 0 Then b(a11(23)) = a11(23): c(23) = a11(23) Else GoTo 230
a11(22) = s1 - a11(11) - a11(33) - a11(44) - a11(55) - a11(66) - a11(77) - a11(88) - a11(99) - a11(110) - a11(121)
If a11(22) < a1(m1) Or a11(22) > a1(m2) Then GoTo 220:
If b1(a11(22)) = 0 Then GoTo 220
If b(a11(22)) = 0 Then b(a11(22)) = a11(22): c(22) = a11(22) Else GoTo 220
a11(12) = p2 - a11(22): If b(a11(12)) = 0 Then b(a11(12)) = a11(12): c(12) = a11(12) Else GoTo 120
' Exclude solutions with identical numbers
GoSub 1800: If fl1 = 0 Then GoTo 5
n9 = n9 + 1
GoSub 2700 'Fill Print Area a15()
GoSub 2650 'Print results (squares)
' GoSub 2645 'Print results (selected numbers)
Erase b, c: GoTo 1500 'Print only first square
5
b(c(12)) = 0: c(12) = 0
120 b(c(22)) = 0: c(22) = 0
220 b(c(23)) = 0: c(23) = 0
230 b(c(33)) = 0: c(33) = 0
330 Next j33
b(c(89)) = 0: c(89) = 0
890 b(c(99)) = 0: c(99) = 0
990 Next j99
b(c(100)) = 0: c(100) = 0
1000 b(c(110)) = 0: c(110) = 0
1100 Next j110
b(c(11)) = 0: c(11) = 0
110 b(c(111)) = 0: c(111) = 0
1110
b(c(3)) = 0: c(3) = 0
30 b(c(113)) = 0: c(113) = 0
1130 Next j113
b(c(2)) = 0: c(2) = 0
20 b(c(112)) = 0: c(112) = 0
1120 Next j112
b(c(1)) = 0: c(1) = 0
10 b(c(121)) = 0: c(121) = 0
1210 Next j121
b(c(10)) = 0: c(10) = 0
100 b(c(120)) = 0: c(120) = 0
1200 Next j120
b(c(9)) = 0: c(9) = 0
90 b(c(119)) = 0: c(119) = 0
1190 Next j119
n10 = 0: Erase b, c
1500 Next j100
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine Priem11h")
End
' Fill Print Area a15()
2700 Erase a15
a15(33) = a11(1): a15(34) = a11(2): a15(35) = a11(3): a15(36) = a11(4): a15(37) = a11(5): a15(38) = a11(6):
a15(39) = a11(7): a15(40) = a11(8): a15(41) = a11(9): a15(42) = a11(10): a15(43) = a11(11):
a15(48) = a11(12): a15(49) = a11(13): a15(50) = a11(14): a15(51) = a11(15): a15(52) = a11(16): a15(53) = a11(17):
a15(54) = a11(18): a15(55) = a11(19): a15(56) = a11(20): a15(57) = a11(21): a15(58) = a11(22):
a15(63) = a11(23): a15(64) = a11(24): a15(65) = a11(25): a15(66) = a11(26): a15(67) = a11(27): a15(68) = a11(28):
a15(69) = a11(29): a15(70) = a11(30): a15(71) = a11(31): a15(72) = a11(32): a15(73) = a11(33):
a15(78) = a11(34): a15(79) = a11(35): a15(80) = a11(36): a15(81) = a11(37): a15(82) = a11(38): a15(83) = a11(39):
a15(84) = a11(40): a15(85) = a11(41): a15(86) = a11(42): a15(87) = a11(43): a15(88) = a11(44):
a15(93) = a11(45): a15(94) = a11(46): a15(95) = a11(47): a15(96) = a11(48): a15(97) = a11(49): a15(98) = a11(50):
a15(99) = a11(51): a15(100) = a11(52): a15(101) = a11(53): a15(102) = a11(54): a15(103) = a11(55):
a15(108) = a11(56): a15(109) = a11(57): a15(110) = a11(58): a15(111) = a11(59): a15(112) = a11(60): a15(113) = a11(61):
a15(114) = a11(62): a15(115) = a11(63): a15(116) = a11(64): a15(117) = a11(65): a15(118) = a11(66):
a15(123) = a11(67): a15(124) = a11(68): a15(125) = a11(69): a15(126) = a11(70): a15(127) = a11(71): a15(128) = a11(72):
a15(129) = a11(73): a15(130) = a11(74): a15(131) = a11(75): a15(132) = a11(76): a15(133) = a11(77):
a15(138) = a11(78): a15(139) = a11(79): a15(140) = a11(80): a15(141) = a11(81): a15(142) = a11(82): a15(143) = a11(83):
a15(144) = a11(84): a15(145) = a11(85): a15(146) = a11(86): a15(147) = a11(87): a15(148) = a11(88):
a15(153) = a11(89): a15(154) = a11(90): a15(155) = a11(91): a15(156) = a11(92): a15(157) = a11(93): a15(158) = a11(94):
a15(159) = a11(95): a15(160) = a11(96): a15(161) = a11(97): a15(162) = a11(98): a15(163) = a11(99):
a15(168) = a11(100): a15(169) = a11(101): a15(170) = a11(102): a15(171) = a11(103): a15(172) = a11(104): a15(173) = a11(105):
a15(174) = a11(106): a15(175) = a11(107): a15(176) = a11(108): a15(177) = a11(109): a15(178) = a11(110):
a15(183) = a11(111): a15(184) = a11(112): a15(185) = a11(113): a15(186) = a11(114): a15(187) = a11(115): a15(188) = a11(116):
a15(189) = a11(117): a15(190) = a11(118): a15(191) = a11(119): a15(192) = a11(120): a15(193) = a11(121):
a15(8) = a(8): a15(22) = a(22): a15(23) = a(23): a15(24) = a(24):
a15(92) = a(92): a15(106) = a(106): a15(107) = a(107): a15(122) = a(122):
a15(104) = a(104): a15(119) = a(119): a15(120) = a(120): a15(134) = a(134):
a15(202) = a(202): a15(203) = a(203): a15(204) = a(204): a15(218) = a(218):
Return
' Print results (selected numbers)
2645 For i1 = 1 To 225
Cells(n9, i1).Value = a15(i1)
Next i1
Cells(n9, 226).Value = n9
Return
' Print results (squares)
2650 n5 = n5 + 1
If n5 = 3 Then
n5 = 1: k1 = k1 + 16: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 16
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 15
For i2 = 1 To 15
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a15(i3)
Next i2
Next i1
Return
' Exclude solutions with identical numbers
1800 fl1 = 1
For j1 = 1 To 121
a2 = a11(j1): If a2 = 0 Then GoTo 1810
For j2 = (1 + j1) To 121
If a2 = a11(j2) Then fl1 = 0: Return
Next j2
1810 Next j1
Return
End Sub
