About the Author

' Semi Bimagic Squares, 9 Bimagic Rows, 9 Bimagic Columns
' Partly Crosswise Symmetric

' Tested with Office 365 under Windows 10

Sub Reformat9()

Dim a1(10, 10), a2(10, 10)

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

    k1 = 1: k2 = 1: n9 = 0
    ShtNm1 = "SemiLns91"        'Intermediate Squares (9 Bimagic Rows, 5 Bimagic Columns)

    Sheets("Klad1").Select

For j100 = 2 To 2233

'   Read Input Square a1()

    i3 = 0
    For i1 = 1 To 9
    For i2 = 1 To 9
        i3 = i3 + 1
        a1(i1, i2) = Sheets(ShtNm1).Cells(j100, i3).Value
    Next i2
    Next i1

'   Rearrange Columns

    Erase a2
    For i1 = 1 To 9
        a2(i1, 1) = a1(i1, 1)
        a2(i1, 2) = a1(i1, 2)
        a2(i1, 3) = a1(i1, 9)
        a2(i1, 4) = a1(i1, 3)
        a2(i1, 5) = a1(i1, 8)
        a2(i1, 6) = a1(i1, 4)
        a2(i1, 7) = a1(i1, 7)
        a2(i1, 8) = a1(i1, 5)
        a2(i1, 9) = a1(i1, 6)
    Next i1

'   Rearrange Rows

    Erase a1
    For i1 = 1 To 9
        a1(1, i1) = a2(1, i1)
        a1(2, i1) = a2(2, i1)
        a1(3, i1) = a2(9, i1)
        a1(4, i1) = a2(3, i1)
        a1(5, i1) = a2(8, i1)
        a1(6, i1) = a2(4, i1)
        a1(7, i1) = a2(7, i1)
        a1(8, i1) = a2(5, i1)
        a1(9, i1) = a2(6, i1)
    Next i1

'   Rearrange pairs Step 1

    For i1 = 2 To 8 Step 2
    For i2 = 2 To 8 Step 2
    
        p2 = a1(i1, i2) + a1(i1 + 1, i2 + 1)
        
        If p2 <> 82 Then
           GoSub 500: If fl1 = 0 Then GoTo 10
        End If
    
    Next i2
    Next i1

'   Rearrange pairs Step 2

    For i1 = 2 To 8 Step 2
    For i2 = 2 To 8 Step 2
    
        p2 = a1(i1, i2 + 1) + a1(i1 + 1, i2)
      
        If p2 <> 82 Then
           GoSub 550: If fl1 = 0 Then GoTo 10
        End If
    
    Next i2
    Next i1

''    n9 = n9 + 1: GoSub 650          'Print Square
      n9 = n9 + 1: GoSub 640          'Print Integers

10 Next j100

End

'   Rearrange pairs Step 1

500 fl1 = 0

    a30 = 82 - a1(i1, i2)
    For i3 = (i2 + 1 + 2) To 9
        
        If a1(i1 + 1, i3) = a30 Then
           a1(i1 + 1, i3) = a1(i1 + 1, i2 + 1)
           a1(i1 + 1, i2 + 1) = a30
           fl1 = 1: Return
        End If
        
    Next i3
'                               Not Possible (fl1 = 0)
    Return

'   Rearrange pairs Step 2

550 fl1 = 0

    a30 = 82 - a1(i1 + 1, i2)
    For i3 = (i2 + 1 + 2) To 9
        
        If a1(i1, i3) = a30 Then
           a1(i1, i3) = a1(i1, i2 + 1)
           a1(i1, i2 + 1) = a30
           fl1 = 1: Return
        End If
        
    Next i3
'                               Not Possible (fl1 = 0)
    Return

'   Print Results (Lines)
   
640 i3 = 0
    For i1 = 1 To 9
    For i2 = 1 To 9
        i3 = i3 + 1
        Cells(n9, i3).Value = a1(i1, i2)
    Next i2
    Next i1
    Cells(n9, 82).Value = n9
    Cells(1, 83).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
        
    i3 = 0
    For i1 = 1 To 9
        For i2 = 1 To 9
            ''i3 = i3 + 1
            Cells(k1 + i1, k2 + i2).Value = a1(i1, i2)
        Next i2
    Next i1
   
    Return

End Sub

About the Author