' Constructs Top Rows s3 = 21, s5 = 35, s15 = 105
' Tested with Office 365 under Windows 11
Sub TopRws15()
Dim a(15), a1(15)
y = MsgBox("Locked", vbCritical, "Routine TopRws15")
End
Sheets("Klad1").Select
For i1 = 1 To 15
a1(i1) = i1 - 1
Next i1
m1 = 1: m2 = 15: s1 = 105
t1 = Timer
For j15 = m1 To m2
a(15) = a1(j15)
For j14 = m1 To m2
a(14) = a1(j14)
If a(14) = a(15) Then GoTo 140
For j13 = m1 To m2
a(13) = a1(j13)
If a(13) = a(14) Or a(13) = a(15) Then GoTo 130
For j12 = m1 To m2
a(12) = a1(j12)
If a(12) = a(13) Or a(12) = a(14) Or a(12) = a(15) Then GoTo 120
For j11 = m1 To m2
a(11) = a1(j11)
If a(11) = a(12) Or a(11) = a(13) Or a(11) = a(14) Or a(11) = a(15) Then GoTo 110
For j10 = m1 To m2
a(10) = a1(j10)
If a(10) = a(12) Or a(10) = a(13) Or a(10) = a(14) Or a(10) = a(15) Then GoTo 100
If a(10) = a(11) Then GoTo 100
For j9 = m1 To m2
a(9) = a1(j9)
If a(9) = a(12) Or a(9) = a(13) Or a(9) = a(14) Or a(9) = a(15) Then GoTo 90
If a(9) = a(10) Or a(9) = a(11) Then GoTo 90
For j8 = m1 To m2
a(8) = a1(j8)
If a(8) = a(12) Or a(8) = a(13) Or a(8) = a(14) Or a(8) = a(15) Then GoTo 80
If a(8) = a(9) Or a(8) = a(10) Or a(8) = a(11) Then GoTo 80
a(7) = 7 + a(8) - a(10) + a(11) - a(12) + a(14) - a(15)
If a(7) < 0 Or a(7) > 14 Then GoTo 80
a(6) = 14 + a(8) - a(9) - a(12) + a(13) - a(15)
If a(6) < 0 Or a(6) > 14 Then GoTo 80
a(5) = 21 - a(10) - a(15)
If a(5) < 0 Or a(5) > 14 Then GoTo 80
a(4) = 21 - a(9) - a(14)
If a(4) < 0 Or a(4) > 14 Then GoTo 80
a(3) = 21 - a(8) - a(13)
If a(3) < 0 Or a(3) > 14 Then GoTo 80
a(2) = 14 - a(8) + a(10) - a(11) - a(14) + a(15)
If a(2) < 0 Or a(2) > 14 Then GoTo 80
a(1) = 7 - a(8) + a(9) - a(11) + a(12) - a(13) + a(15)
If a(1) < 0 Or a(1) > 14 Then GoTo 80
GoSub 800: If fl1 = 0 Then GoTo 80 'Check Identical Numbers
GoSub 850: If fl1 = 0 Then GoTo 80 'Check Symmetry (Option)
n9 = n9 + 1: GoSub 640 'Print TopRows
''n9 = n9 + 1: Cells(n10, 29).Value = n9 'Counting
80 Next j8
90 Next j9
100 Next j10
110 Next j11
120 Next j12
130 Next j13
140 Next j14
150 Next j15
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine TopRws15")
End
' Print results (selected numbers)
640 For i1 = 1 To 15
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 16).Value = n9
Cells(n9, 17).Value = n10
Return
' Exclude solutions with identical numbers
800 fl1 = 1
For j1 = 1 To 15
a2 = a(j1)
For j2 = (1 + j1) To 15
If a2 = a(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
' Check Symmetry
850 fl1 = 1
For i1 = 1 To 7
If a(i1) + a(16 - i1) <> 14 Then fl1 = 0: Return
Next i1
Return
End Sub
