Problème fichier se fige après copier/collage ou rajout de lignes

Private Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, [E2:E65536])
If Target Is Nothing Then Exit Sub
Dim T As String, s As Object, e As Byte
Application.ScreenUpdating = False
ThisWorkbook.DisplayDrawingObjects = xlAll

'---Effacement---
T = Target.Cells(1, 1).Formula
Application.EnableEvents = False
Target.ClearContents
Target.Font.ColorIndex = xlAutomatic
For Each s In ActiveSheet.Shapes
  If s.TopLeftCell = "" And s.TopLeftCell.Column = 5 Then s.Delete
Next
Set Target = Target.Cells(1, 1)
Target.Formula = T
Application.EnableEvents = True

'---Création de la forme---
If IsNumeric(Target) Then 'en cas de valeur d'erreur
  If Target > 0 And Target <= 9 Then
    Target.Font.ColorIndex = 2
    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, 100, 15)
      .OnAction = "Selectionne"
      .Fill.Visible = msoFalse
      .Line.Visible = msoFalse
      With .TextFrame
        e = Int(CDec(Target))
        .Characters.Text = Application.Rept("ê", e - (Target > e))
        .Characters.Font.Name = "Wingdings 2"
        .Characters.Font.ColorIndex = [H4].Offset(Target - e < 0.5).Font.ColorIndex
        If e > 0 Then .Characters(1, e).Font.ColorIndex = [H5].Font.ColorIndex
        .AutoSize = True
      End With
      .Left = Target.Left + Application.Max(0, (Target.Width - .Width) / 2)
      .Top = Target.Top + Application.Max(0, 1 + (Target.Height - .Height) / 2)
    End With
  End If
End If
Application.OnRepeat "", ""
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Target
    If .Column = 2 Then
        Cancel = True
        If .Comment Is Nothing Then
            .AddComment
            .Comment.Shape.Width = 124.5
            .Comment.Shape.Height = 22.6
        End If
        SendKeys "%im"
    End If
End With
End Sub