XL 2016 Excel bugge quand j'essaie d'insérer une ligne

Sub test_A()
'Déclarations des variabes
Dim vArr As Variant, Rng As Range
'Mise en mémoire (Array) du contenu du tableau
vArr = ActiveSheet.ListObjects(1).DataBodyRange.Value2
'Recopie sur une feuille provisoire
With Sheets("RECOPIE 1").Range("A7").Resize(UBound(vArr, 1), UBound(vArr, 2))
    .Value = vArr
    'insertion des titres
    .Item(1).Offset(-1).Resize(, 5) = Array("DATE", "LIBELLE", "MODE", "DEBIT", "CREDIT")
    .Columns.AutoFit
End With
'Définition d'un plage de cellules
Set Rng = Sheets("RECOPIE 1").Range("A6").CurrentRegion
'Recréation du tableau sur la feuille provisoire
Sheets("RECOPIE 1").ListObjects.Add(xlSrcRange, Rng, , xlYes).Name = "Tableau_test"
End Sub

Sub test_B()
Dim vArr, Feuilles, i%, Rng As Range
Feuilles = Array(Array("RECOPIE 1", "CLASSEUR 1"), Array("RECOPIE 2", "CLASSEUR 2"))
For i = LBound(Feuilles) To UBound(Feuilles)
With Sheets(Feuilles(i)(0))
    vArr = Sheets(Feuilles(i)(1)).ListObjects(1).DataBodyRange.Value2
    .Range("A7").Resize(UBound(vArr, 1), UBound(vArr, 2)).Value = vArr
    .Range("A6:E6") = Array("DATE", "LIBELLE", "MODE", "DEBIT", "CREDIT")
    .Columns.AutoFit
    Erase vArr
    Set Rng = .Range("A6").CurrentRegion
    .ListObjects.Add(xlSrcRange, Rng, , xlYes).Name = "Tableau_" & Int(Rnd * 50 + 1)
End With
Next
End Sub

Sub Sherlock()
WTF 1600
End Sub
Private Sub WTF(numShape)
Dim shp As Shape, shpp As Shape, shpName As String, aDr$, i&
Application.ScreenUpdating = False
Set shp = ActiveSheet.Shapes(numShape)
shp.Height = 50: shp.Width = 50
    Set shpp = shp.Duplicate
    shpp.AlternativeText = shp.TopLeftCell.Address
    shpp.Cut
        With Sheets("test")
        .Paste
        .Shapes(1).Fill.ForeColor.RGB = vbRed
    End With
End Sub