' Recalculates Semi Bimagic Squares Order 10
' 10 Bimagic Columns
' Tested with Office 365 under Windows 11
Sub CnstrSqrs10b()
Dim a(100), a0(10, 10), a1(10), a2(10)
Dim n(10, 2)
y = MsgBox("Blocked", vbExclamation, "CnstrSqrs10b")
End
Sheets("Klad1").Select
n1 = 0: n9 = 0: k1 = 1: k2 = 1
ShtNm1 = "GenLns10"
ShtNm2 = "ScrSht10"
t1 = Timer
' Recalculates Last 7 Columns
For j100 = 3418 To 3534
i2 = 1: i3 = 0
For i1 = 1 To 100:
i3 = i3 + 1: If i3 = 11 Then i3 = 1: i2 = i2 + 1
a0(i2, i3) = Sheets(ShtNm1).Cells(j100, i1)
Next i1
s1 = 505: s2 = 33835
Sheets(ShtNm2).Select
Cells.Select: Selection.ClearContents
Range("A1").Select
GoSub 500 ' Prepare Scratch Sheet
Sheets("Klad1").Select
For j1 = n(Ln10, 1) To n(Ln10, 2)
n10 = 10: Erase a
For i1 = 1 To 10
a1(i1) = Sheets(ShtNm2).Cells(j1, i1).Value
Next i1
For i1 = 1 To 10 ' First Line
a(i1) = a1(i1)
Next i1
For j2 = n(Ln10 + 1, 1) To n(Ln10 + 1, 2)
j300 = j2: GoSub 100: If fl1 = 0 Then GoTo 20
For j3 = n(Ln10 + 2, 1) To n(Ln10 + 2, 2)
j300 = j3: GoSub 100: If fl1 = 0 Then GoTo 30
For j4 = n(Ln10 + 3, 1) To n(Ln10 + 3, 2)
j300 = j4: GoSub 100: If fl1 = 0 Then GoTo 40
For j5 = n(Ln10 + 4, 1) To n(Ln10 + 4, 2)
j300 = j5: GoSub 100: If fl1 = 0 Then GoTo 50
For j6 = n(Ln10 + 5, 1) To n(Ln10 + 5, 2)
j300 = j6: GoSub 100: If fl1 = 0 Then GoTo 60
For j7 = n(Ln10 + 6, 1) To n(Ln10 + 6, 2)
j300 = j7: GoSub 100: If fl1 = 0 Then GoTo 70
'' For j8 = n(8, 1) To n(8, 2)
'' j300 = j8: GoSub 100: If fl1 = 0 Then GoTo 80
'' For j9 = n(9, 1) To n(9, 2)
'' j300 = j9: GoSub 100: If fl1 = 0 Then GoTo 90
'' For j10 = n(10, 1) To n(10, 2)
'' j300 = j10: GoSub 100: If fl1 = 0 Then GoTo 105
GoSub 700 'Replace Columns
n9 = n9 + 1: GoSub 750 'Print Semi Magic Squares
''End
5
'' n10 = n10 - 10
''105 Next j10
'' n10 = n10 - 10
''90 Next j9
'' n10 = n10 - 10
''80 Next j8
n10 = n10 - 10
70 Next j7
n10 = n10 - 10
60 Next j6
n10 = n10 - 10
50 Next j5
n10 = n10 - 10
40 Next j4
n10 = n10 - 10
30 Next j3
n10 = n10 - 10
20 Next j2
n10 = n10 - 10
10 Next j1
1000 Next j100
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CnstrSqrs10b")
End
' Prepare Scratch Sheet
500 Ln10 = 4 '*** Start with Ln10 (Normal Ln10 = 1) ***
i90 = 0: n(Ln10, 1) = 1
For i1 = Ln10 To 10
For i2 = Ln10 To 10
For i3 = Ln10 To 10
For i4 = Ln10 To 10
For i5 = Ln10 To 10
For i6 = Ln10 To 10
For i7 = Ln10 To 10
For i8 = Ln10 To 10
For i9 = Ln10 To 10
For i10 = Ln10 To 10
s11 = a0(1, i1) + a0(2, i2) + a0(3, i3) + a0(4, i4) + a0(5, i5) + a0(6, i6) + a0(7, i7) + a0(8, i8) + a0(9, i9) + a0(10, i10)
If s11 <> s1 Then GoTo 600
s12 = a0(1, i1) ^ 2 + a0(2, i2) ^ 2 + a0(3, i3) ^ 2 + a0(4, i4) ^ 2 + a0(5, i5) ^ 2 + a0(6, i6) ^ 2 + a0(7, i7) ^ 2 + a0(8, i8) ^ 2 + a0(9, i9) ^ 2 + a0(10, i10) ^ 2
If s12 <> s2 Then GoTo 600
i90 = i90 + 1
Cells(i90, 1).Value = a0(1, i1)
Cells(i90, 2).Value = a0(2, i2)
Cells(i90, 3).Value = a0(3, i3)
Cells(i90, 4).Value = a0(4, i4)
Cells(i90, 5).Value = a0(5, i5)
Cells(i90, 6).Value = a0(6, i6)
Cells(i90, 7).Value = a0(7, i7)
Cells(i90, 8).Value = a0(8, i8)
Cells(i90, 9).Value = a0(9, i9)
Cells(i90, 10).Value = a0(10, i10)
Cells(i90, 11).Value = s11 ''j100
Cells(i90, 12).Value = s12
Cells(1, 13).Value = i90
Cells(2, 13).Value = i1
Cells(3, 13).Value = j100
Cells(4, 13).Value = n9
600 Next i10
590 Next i9
580 Next i8
570 Next i7
560 Next i6
550 Next i5
540 Next i4
530 Next i3
520 Next i2
n(i1, 2) = i90: If i1 <> 10 Then n(i1 + 1, 1) = i90 + 1
510 Next i1
n(10, 2) = i90
Return
' Construct Semi Magic Squares
100 fl1 = 1
For i1 = 1 To 10
a2(i1) = Sheets(ShtNm2).Cells(j300, i1).Value
Next i1
For i1 = 1 To 10
a20 = a2(i1)
For i2 = 1 To n10
If a20 = a(i2) Then fl1 = 0: Return
Next i2
Next i1
n10 = n10 + 10
i2 = 0
For i1 = n10 - 10 + 1 To n10
i2 = i2 + 1
a(i1) = a2(i2)
Next i1
Return
' Replace Columns
700
a0(1, 4) = a(1): a0(1, 5) = a(11): a0(1, 6) = a(21): a0(1, 7) = a(31): a0(1, 8) = a(41): a0(1, 9) = a(51): a0(1, 10) = a(61)
a0(2, 4) = a(2): a0(2, 5) = a(12): a0(2, 6) = a(22): a0(2, 7) = a(32): a0(2, 8) = a(42): a0(2, 9) = a(52): a0(2, 10) = a(62)
a0(3, 4) = a(3): a0(3, 5) = a(13): a0(3, 6) = a(23): a0(3, 7) = a(33): a0(3, 8) = a(43): a0(3, 9) = a(53): a0(3, 10) = a(63)
a0(4, 4) = a(4): a0(4, 5) = a(14): a0(4, 6) = a(24): a0(4, 7) = a(34): a0(4, 8) = a(44): a0(4, 9) = a(54): a0(4, 10) = a(64)
a0(5, 4) = a(5): a0(5, 5) = a(15): a0(5, 6) = a(25): a0(5, 7) = a(35): a0(5, 8) = a(45): a0(5, 9) = a(55): a0(5, 10) = a(65)
a0(6, 4) = a(6): a0(6, 5) = a(16): a0(6, 6) = a(26): a0(6, 7) = a(36): a0(6, 8) = a(46): a0(6, 9) = a(56): a0(6, 10) = a(66)
a0(7, 4) = a(7): a0(7, 5) = a(17): a0(7, 6) = a(27): a0(7, 7) = a(37): a0(7, 8) = a(47): a0(7, 9) = a(57): a0(7, 10) = a(67)
a0(8, 4) = a(8): a0(8, 5) = a(18): a0(8, 6) = a(28): a0(8, 7) = a(38): a0(8, 8) = a(48): a0(8, 9) = a(58): a0(8, 10) = a(68)
a0(9, 4) = a(9): a0(9, 5) = a(19): a0(9, 6) = a(29): a0(9, 7) = a(39): a0(9, 8) = a(49): a0(9, 9) = a(59): a0(9, 10) = a(69)
a0(10, 4) = a(10): a0(10, 5) = a(20): a0(10, 6) = a(30): a0(10, 7) = a(40): a0(10, 8) = a(50): a0(10, 9) = a(60): a0(10, 10) = a(70)
Return
' Print results (Semi Magic Squares)
' Related number of Magic Squares Shown (n29)
750 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 11: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 11
End If
'' Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
Cells(k1, k2 + 2).Value = n29
Cells(k1, k2 + 10).Value = j100 'Generator Magic Lines
i3 = 0
For i1 = 1 To 10
For i2 = 1 To 10
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a0(i1, i2) ''a(i3) ''
Next i2
Next i1
Return
End Sub
