About the Author

' Semi Bimagic Squares, 9 Bimagic Rows, 5 Bimagic Columns
' Based on Generators, 9 Bimagic Rows, 1 Bimagic Column

' Tested with Office 365 under Windows 10

Sub CnstrSqr9a()

Dim a(9, 9), a1(9), a2(9), b(81)
Dim nRw(85, 2), nClm(85, 2)
Dim Ln9(5), Rw9(81), Clm9(81)

y = MsgBox("Blocked", vbExclamation, "CnstrSqr9a")
End

    k1 = 1: k2 = 1: n9 = 0
    ShtNm1 = "GenLns91"          'Generators, 9 Bimagic Rows, 1 Bimagic Column
    ShtNm2 = "Clmn94"            'Anti Symmetric Lines Corresponding with j10 = 2
    
'   Applicable Ranges in 'GenLns91'
    
    For i1 = 2 To 83
        nRw(i1, 1) = Sheets(ShtNm1).Cells(i1, 88).Value    'from
        nRw(i1, 2) = Sheets(ShtNm1).Cells(i1, 89).Value    'to
    Next i1
    
'   Applicable Ranges in 'Clmn94'
    
    For i1 = 2 To 83
        nClm(i1, 1) = Sheets(ShtNm2).Cells(i1, 43).Value    'from
        nClm(i1, 2) = Sheets(ShtNm2).Cells(i1, 44).Value    'to
    Next i1
    
'   Select Anti Symmetric Lines

    Sheets("Klad1").Select

    t1 = Timer
   
    For j100 = 2 To 83           'Set Symmetric Series, 19 ok

      For j10 = nRw(j100, 1) To nRw(j100, 2) 'Generators (Rows)

'        Read Generator

         i1 = 1: i2 = 0
         For i3 = 1 To 81
             i2 = i2 + 1
             If i2 = 10 Then i2 = 1: i1 = i1 + 1
             a(i1, i2) = Sheets(ShtNm1).Cells(j10, i3).Value
         Next i3
    
         For j30 = nClm(j100, 1) To nClm(j100, 2) 'Possible Set Columns
    
'        Construct Columns 2, 3, 4, 5
    
         For j20 = 2 To 5 ''5

            Erase b, Rw9, Clm9
            For i1 = 2 To 9             'Rows
            For i2 = j20 To 9           'Columns
                x = a(i1, i2):
                    b(a(i1, i2)) = x
                    Rw9(x) = i1         'Indices
                    Clm9(x) = i2
            Next i2
            Next i1
        
            GoSub 100                   'Construc Column j20
            
            If fl1 = 0 Then GoTo 30
            
20     Next j20
     
      n9 = n9 + 1: GoSub 650            'Print Square
''    n9 = n9 + 1: GoSub 640            'Print Integers
    
30    Next j30
10    Next j10

1000  Next j100

    t2 = Timer

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

End

'   Construct Columns 2, 3, 4, 5

100 fl1 = 0
       
    For i1 = 1 To 9
        a1(i1) = Sheets(ShtNm2).Cells(j30, i1 + (j20 - 2) * 9)
    Next i1
        
'   Check Integers
        
    For i1 = 2 To 9
        If b(a1(i1)) = 0 Then Return
    Next i1

'   Check Row Indices
        
    For i1 = 2 To 9
        r20 = Rw9(a1(i1))
        For i2 = i1 + 1 To 9
            If r20 = Rw9(a1(i2)) Then Return
        Next i2
    Next i1
        
'   Exckange Integers Column j20

    fl1 = 1
    For i1 = 2 To 9
        a20 = a1(i1):      r20 = Rw9(a20):    c20 = Clm9(a20)
        a10 = a(r20, j20):
        a(r20, j20) = a20: a(r20, c20) = a10
    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 = 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   'Generator (Rows)
    Cells(k1, k2 + 3).Value = j30   'Bimagic Columns
        
    i3 = 0
    For i1 = 1 To 9
        For i2 = 1 To 9
            ''i3 = i3 + 1
            Cells(k1 + i1, k2 + i2).Value = a(i1, i2)
        Next i2
    Next i1
   
    Return

End Sub

About the Author