' Base Generators, Based on Symmetric Bimagic Euler Series
' Tested with Office 365 under Windows 10
Sub BaseGen9()
Dim a(9, 9), a1(9), a2(9)
y = MsgBox("Blocked", vbExclamation, "BaseGen9")
End
k1 = 1: k2 = 1: n9 = 0
ShtNm1 = "LtnCntr9"
' Select Center Lines
Sheets("Klad1").Select
For j10 = 2 To 17
i2 = 0
For i1 = 1 To 9:
If i1 <> 5 Then
i2 = i2 + 1
a1(i2) = Sheets(ShtNm1).Cells(j10, i1).Value:
End If
Next i1
For j20 = j10 + 1 To 17
i2 = 0
For i1 = 1 To 9:
If i1 <> 5 Then
i2 = i2 + 1
a2(i2) = Sheets(ShtNm1).Cells(j20, i1).Value:
End If
Next i1
' Check Center Lines
GoSub 500: If fl1 = 0 Then GoTo 200
a(1, 1) = 41
For i1 = 1 To 8
a(1, i1 + 1) = a1(i1)
Next i1
For i1 = 1 To 8
a(i1 + 1, 1) = a2(i1)
Next i1
n9 = n9 + 1: GoSub 640 'Lines
'' n9 = n9 + 1: GoSub 650 'Squares
200 Next j20
100 Next j10
End
' Check Center Lines
500 fl1 = 1
For i1 = 1 To 8
For i2 = 1 To 8
If a1(i1) = a2(i2) Then fl1 = 0: Return
Next i2
Next i1
Return
' Print Results (Lines)
640 i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
i3 = i3 + 1
Cells(n9, i3).Value = a(i1, i2)
Next i2
Next i1
Cells(n9, 82).Value = j10
Cells(n9, 83).Value = j20
Cells(n9, 84).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).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
Cells(k1, k2 + 2).Value = j10
Cells(k1, k2 + 3).Value = j20
i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
Cells(k1 + i1, k2 + i2).Value = a(i1, i2)
Next i2
Next i1
Return
End Sub
