Microsoft 365 Copier coller une feuille dans le même classeur contenant des shapes

Sub TestRechercherDimensionsShape()
       
Dim ShShapes As Worksheet, ShRapport As Worksheet
Dim ShapeRecherche As Shape
Dim AireShapes As Range
Dim LigneEnCours As Long

    Set ShShapes = Sheets("Feuil4") ' A adapter
    Set ShRapport = Sheets.Add(after:=ShShapes)
   
        With ShRapport
             .Range(.Cells(1, 1), .Cells(1, 5)) = Array("Forme", "Longueur", "Hauteur", "Angle", "Nom")
             LigneEnCours = 2
             For Each ShapeRecherche In ShShapes.Shapes
                 With ShRapport.Cells(LigneEnCours, 1)
                      .Value = ShapeRecherche.AutoShapeType
                      .Offset(0, 1) = ShapeRecherche.Width
                      .Offset(0, 2) = ShapeRecherche.Height
                      .Offset(0, 3) = ShapeRecherche.Rotation
                      .Offset(0, 4) = ShapeRecherche.Name
                      LigneEnCours = LigneEnCours + 1
                 End With
             Next ShapeRecherche
           
             Set AireShapes = .Range("A1").CurrentRegion
           
            .Sort.SortFields.Clear
            .Sort.SortFields.Add2 Key:=AireShapes.Columns(5), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With .Sort
                .SetRange AireShapes
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With

        End With
       
        Set ShRapport = Nothing: Set ShShapes = Nothing:  Set AireShapes = Nothing
       
End Sub