Code to insert rows in next sheet in order of Column B

[kosherboy]

Hi all.
The below code used to work for me perfectly but in the last couple days it's been acting up. The code is supposed to cut out 2 rows from sheet1 and insert it in order of column B in sheet2. Up until a few days ago the code was inserting the 2, cut, rows properly but now it inserts it at the top of the sheet.

Here is the workbook i'm working with TEST.xlsm

Any help would be greatly appreciated

Thanks.

Sub INSERT_ROWS()
Dim LR As Long

With ActiveCell
  If .Column = 1 Then
    If (.Row Mod 2 = 0) Then Exit Sub
  Else
    Exit Sub
  End If
End With

        
        If Selection.Column = 1 Then Selection.Resize(2, 1).EntireRow.Select
        Selection.Cut
        Sheets("Sheet2").Select
    Rows("5:5").Select
    Selection.Insert Shift:=xlDown
       
        LR = Range("A" & Rows.Count).End(xlUp).Row

Range("BA5").Select
    ActiveCell.Formula = "=B5"
Range("BA6").Select
 ActiveCell.Formula = "=BA5"
    Range("BA5:BA6").Select

If Application.IsOdd(LR) Then
    Range("BA5:BA6").AutoFill Destination:=Range("BA5:BA" & LR + 1)
Else
    Range("BA5:BA6").AutoFill Destination:=Range("BA5:BA" & LR)
End If

Range("BA5:BA5000").Select
Rows("5:5000").Select
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range( _
        "BA5:BA5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("A5:BA5000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With