Inserting blank rows now running very slow

Try this

Sub test()
    Application.ScreenUpdating = False
    Columns(1).Insert
    With Range("b3", Range("b" & Rows.Count).End(xlUp)).Offset(, -1)
        .Formula = "=if(b2<>b3,if(a2=1,""a"",1),"""")"
        .Value = .Value
        On Error Resume Next
        .SpecialCells(2, 1).EntireRow.Insert
        .SpecialCells(2, 2).EntireRow.Insert
        On Error GoTo 0
    End With
    Columns(1).Delete
    Application.ScreenUpdating = True
End Sub