' Generators based on Bimagic Euler Series (Collection A)
' 9 Bimagic Rows, 1 Bimagic Column
' Tested with Office 365 under Windows 10
Sub Generator9a()
Dim a(81), a1(9), a2(9), b(81)
Dim n(81, 2)
Dim Ln9(5)
y = MsgBox("Blocked", vbExclamation, "Generator9a")
End
k1 = 1: k2 = 1: n9 = 0
ShtNm1 = "GenLns9a" 'Pre Selected Center Lines j10 = 2 to 85
ShtNm2 = "LtnLns9" 'Anti Symmetric Lines
Sheets("Klad1").Select
' Applicable Ranges in 'LtnLns9'
For i1 = 2 To 81
i2 = Sheets(ShtNm2).Cells(i1, 13).Value
n(i2, 1) = Sheets(ShtNm2).Cells(i1, 14).Value 'from
n(i2, 2) = Sheets(ShtNm2).Cells(i1, 15).Value 'to
Next i1
' Select Anti Symmetric Lines
t1 = Timer
For j10 = 2 To 85 'No Results for 37
' First Line
Ln9(1) = 1
n10 = 9: Erase a, b
For i1 = 1 To 9
a(i1) = Sheets(ShtNm1).Cells(j10, i1).Value
Next i1
For i1 = 1 To 9
b(a(i1)) = a(i1)
Next i1
For i1 = 10 To 17
i2 = Sheets(ShtNm1).Cells(1, i1).Value
a(i2) = Sheets(ShtNm1).Cells(j10, i1).Value
Next i1
m2 = a(10): m3 = a(19): m4 = a(28): m5 = a(37)
' Lines 2, 3, 4, 5
For j2 = n(m2, 1) To n(m2, 2)
j300 = j2: GoSub 100: If fl1 = 0 Then GoTo 20
Ln9(2) = j2
For j3 = n(m3, 1) To n(m3, 2)
j300 = j3: GoSub 100: If fl1 = 0 Then GoTo 30
Ln9(3) = j3
For j4 = n(m4, 1) To n(m4, 2)
j300 = j4: GoSub 100: If fl1 = 0 Then GoTo 40
Ln9(4) = j4
For j5 = n(m5, 1) To n(m5, 2)
j300 = j5: GoSub 100: If fl1 = 0 Then GoTo 50
Ln9(5) = j5
' Line 6, 7, 8, 9 (Complementar)
For i1 = 46 To 54: a(i1) = 82 - a(i1 - 9): Next i1
For i1 = 55 To 63: a(i1) = 82 - a(i1 - 3 * 9): Next i1
For i1 = 64 To 72: a(i1) = 82 - a(i1 - 5 * 9): Next i1
For i1 = 73 To 81: a(i1) = 82 - a(i1 - 7 * 9): Next i1
GoSub 500: If fl1 = 0 Then GoTo 5 'Back Check
'' n9 = n9 + 1: GoSub 650 'Print results (squares)
n9 = n9 + 1: GoSub 640 'Print results (lines)
5
For i1 = n10 - 9 + 1 To n10: b(a(i1)) = 0: b(82 - a(i1)) = 0: Next i1
n10 = n10 - 9
50 Next j5
For i1 = n10 - 9 + 1 To n10: b(a(i1)) = 0: b(82 - a(i1)) = 0: Next i1
n10 = n10 - 9
40 Next j4
For i1 = n10 - 9 + 1 To n10: b(a(i1)) = 0: b(82 - a(i1)) = 0: Next i1
n10 = n10 - 9
30 Next j3
For i1 = n10 - 9 + 1 To n10: b(a(i1)) = 0: b(82 - a(i1)) = 0: Next i1
n10 = n10 - 9
20 Next j2
Next j10
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine Generator9a")
End
' Construct Semi Magic Squares
100 fl1 = 1
For i1 = 1 To 9
a2(i1) = Sheets(ShtNm2).Cells(j300, i1).Value
If b(a2(i1)) <> 0 Then fl1 = 0: Return
If b(82 - a2(i1)) <> 0 Then fl1 = 0: Return
Next i1
For i1 = 1 To 9
b(a2(i1)) = a2(i1)
b(82 - a2(i1)) = 82 - a2(i1) 'ommplement
Next i1
n10 = n10 + 9
i2 = 0
For i1 = n10 - 9 + 1 To n10
i2 = i2 + 1
a(i1) = a2(i2)
Next i1
Return
' Check Identical Numbers
500 fl1 = 1
For i1 = 1 To 81
a20 = a(i1)
For i2 = i1 + 1 To 81
If a(i2) = a20 Then fl1 = 0: Return
Next i2
Next i1
Return
' Print Results (Lines)
640 i3 = 0
For i3 = 1 To 81
Cells(n9, i3).Value = a(i3)
Next i3
Cells(n9, 82).Value = j10
Cells(n9, 83).Value = n9
Cells(1, 84).Value = j10
Cells(1, 85).Value = n9
Return
' Print Results (Squares)
650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 10: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 10
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
Cells(k1, k2 + 2).Value = j10
Cells(1, 1).Value = n9
i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
