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

pat66

XLDnaute Impliqué
Bonjour le forum,

lorsque on fait un copier coller d'une feuille dans le même classeur, les shapes sont automatiquement renommées sur la nouvelle feuille

est t'il possible de faire en sorte que les macros tiennent compte de ces nouveaux noms ou faut il les modifier une par une ?

merci
 
Dernière édition:

Eric KERGRESSE

XLDnaute Occasionnel
Bonjour à tous,

Logiquement avec un simple copier-coller, les formes dupliquées portent le même nom.
Faites l'essai avec ce code pour recenser vos formes après un copier-coller :

VB:
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
 

Discussions similaires

Statistiques des forums

Discussions
313 296
Messages
2 096 919
Membres
106 786
dernier inscrit
Mgordat