About the Author

' Constructs Semi Bimagic Squares Order 10 (Non Itterative)
' 6 to 8 Bimagic Columns

' Tested with Office 365 under Windows 11

Sub SemiSqrs10a()

Dim a(100), a0(10, 10), a1(10), a2(10)

y = MsgBox("Blocked", vbInformation, "SemiSqrs10a")
End

n1 = 0: n9 = 0: k1 = 1: k2 = 15

s1 = 505: s2 = 33835

ShtNm1 = "HalfGen10c"

Sheets("Klad1").Select

t1 = Timer

For j100 = 862 To 2848 ''309 To 2908
    
    i2 = 1: i3 = 0
    For i1 = 1 To 50
        i3 = i3 + 1: If i3 = 11 Then i3 = 1: i2 = i2 + 1
        a0(i2, i3) = Sheets(ShtNm1).Cells(j100, i1)
    Next i1
    
For j101 = j100 To j100 ''2909 To 5517
    
    i2 = 6: i3 = 0
    For i1 = 1 To 50
        i3 = i3 + 1: If i3 = 11 Then i3 = 1: i2 = i2 + 1
        a0(i2, i3) = Sheets(ShtNm1).Cells(j101, i1 + 50)
    Next i1

     i19 = 0
     For j200 = 1 To 10
         GoSub 500                 'Search for Bimagic Line
         If fl1 = 0 Then Exit For  'Not Found
2000 Next j200

If j200 < 4 Then GoTo 1100 ''normaliter j200 = 6, 7 or 8
n9 = n9 + 1: GoSub 650: 

1100 Next j101
1000 Next j100

t2 = Timer
    
    t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
    y = MsgBox(t10, 0, "Routine SemiSqrs10a")

End

'   Search for Bimagic Line

500 fl1 = 1

For i1 = j200 To 10
For i2 = j200 To 10
For i3 = j200 To 10
For i4 = j200 To 10
For i5 = j200 To 10
For i6 = j200 To 10
For i7 = j200 To 10
For i8 = j200 To 10
For i9 = j200 To 10
For i10 = j200 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
    
'   *** Test ***
    
    i19 = i19 + 1
    Cells(i19, 1).Value = a0(1, i1)
    Cells(i19, 2).Value = a0(2, i2)
    Cells(i19, 3).Value = a0(3, i3)
    Cells(i19, 4).Value = a0(4, i4)
    Cells(i19, 5).Value = a0(5, i5)
    Cells(i19, 6).Value = a0(6, i6)
    Cells(i19, 7).Value = a0(7, i7)
    Cells(i19, 8).Value = a0(8, i8)
    Cells(i19, 9).Value = a0(9, i9)
    Cells(i19, 10).Value = a0(10, i10)
    Cells(i19, 11).Value = j100
    Cells(i19, 12).Value = j101
    Cells(i19, 13).Value = j200
    Cells(i19, 13).Select

'  Swap Variables

   a1(1) = a0(1, i1): a1(2) = a0(2, i2): a1(3) = a0(3, i3): a1(4) = a0(4, i4): a1(5) = a0(5, i5)
   a1(6) = a0(6, i6): a1(7) = a0(7, i7): a1(8) = a0(8, i8): a1(9) = a0(9, i9): a1(10) = a0(10, i10)
   
   a0(1, i1) = a0(1, j200)
   a0(2, i2) = a0(2, j200)
   a0(3, i3) = a0(3, j200)
   a0(4, i4) = a0(4, j200)
   a0(5, i5) = a0(5, j200)
   a0(6, i6) = a0(6, j200)
   a0(7, i7) = a0(7, j200)
   a0(8, i8) = a0(8, j200)
   a0(9, i9) = a0(9, j200)
   a0(10, i10) = a0(10, j200)
   
   For j1 = 1 To 10
       a0(j1, j200) = a1(j1)
   Next j1
   
   Return

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
510 Next i1
    
    fl1 = 0
    
    Return

'   Print results (squares)

650 n2 = n2 + 1
    If n2 = 5 Then
        n2 = 1: k1 = k1 + 11: k2 = 15
    Else
        If n9 > 1 Then k2 = k2 + 11
    End If

    Cells(k1, k2 + 1).Font.Color = -4165632
    Cells(k1, k2 + 1).Value = n9
    Cells(k1, k2 + 2).Value = j100
''  Cells(k1, k2 + 3).Value = j101
    Cells(k1, k2 + 4).Value = j200 - 1
    
    Cells(1, 14).Value = n9
    
    i3 = 0
    For i1 = 1 To 10
        For i2 = 1 To 10
            Cells(k1 + i1, k2 + i2).Value = a0(i1, i2)
        Next i2
    Next i1

    Return

End Sub

About the Author