About the Author

' Generators based on Bimagic Euler Series (Collection B)
' 4 Bimagic Columns

' Tested with Office 365 under Windows 10

Sub Generator9b()

Dim a(81), a1(9), a2(9), b(81)
Dim n(81, 2)
Dim Ln9(5)

y = MsgBox("Blocked", vbExclamation, "Generator9b")
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
    
    n10 = 0: Erase a, b
    
'   Define Ranges
    
    For i1 = 1 To 17
        a(i1) = Sheets(ShtNm1).Cells(j10, i1).Value
        If i1 > 9 Then b(a(i1)) = a(i1)
    Next i1

    m2 = a(2): m3 = a(3): m4 = a(4): m5 = a(5)

    Erase a

'   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
    
       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 Generator9b")

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 36
        a20 = a(i1)
        For i2 = i1 + 1 To 36
            If a(i2) = a20 Then fl1 = 0: Return
        Next i2
510 Next i1
    
    Return

'   Print Results (Lines)
   
640 i3 = 0
    For i3 = 1 To 36
        Cells(n9, i3).Value = a(i3)
    Next i3
    Cells(n9, 37).Value = j10
    Cells(n9, 38).Value = n9
    Cells(1, 39).Value = j10
    Cells(1, 40).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

About the Author