Microsoft 365 Déplacement Shape

Cédric06400 · 6 Octobre 2024

Bonjour à tous,

J'ai créer un macro qui permet de déplacer une image sélectionnée dans une feuille de calculs.
J'ai un MsgBox qui s'affiche si avant de lancer la macro aucune image est sélectionnée.

Ca tourne très bien

Sub DéplacImage1()

Dim Img As Excel.Picture
Dim Cel As Integer

Cel = 117

If Not TypeOf Selection Is Excel.Picture Then
MsgBox "Veuillez selectionner une image", vbCritical, "DéplacImage1"
Exit Sub: End If
Set Img = Selection

Selection.Cut
Range("A" & Cel).Select
ActiveSheet.Paste
Set Img = Selection
Img.Top = Range("A" & Cel).Top + 22
Img.Left = Range("A" & Cel).Left + 2
Selection.ShapeRange.IncrementLeft -16
End Sub

Je veux créer un macro similaire pour déplacer des AutoShape par dessus les photos précédemment déplacées
J'utilise des autoshape pour pouvoir les lier avec le contenu d'une cellule, un autoshape n'a pas de nom

Le hic c'est que je n'arrive pas à créer le MsgBox avec le shape sélectionné

Sub DeplaceShape()

Dim Cel As Integer
Cel = 117

' If Not TypeOf Selection Is Shape Then
' MsgBox "Veuillez selectionner une anomalie", vbCritical, "DeplaceShape"
' Exit Sub: End If

Selection.Cut
Range("A" & Cel).Select
ActiveSheet.Paste
Selection.ShapeRange.Top = Range("A" & Cel).Top + 22
Selection.ShapeRange.Left = Range("A" & Cel).Left + 2
Selection.ShapeRange.IncrementLeft -16
End Sub

Je nes uis pas certains qu'on puisse le faire avec la meme methode.

Pourriez vous m'aider ?

Bien à vous

Cédric

Staple1600 · 6 Octobre 2024

Bonsoir le fil

@Cédric06400
A adapter à tes besoins

VB:

Sub Test_AutoShape()
    Dim shp As Shape, obj As Object
    On Error Resume Next
    Set obj = Selection.ShapeRange(1)
    If obj Is Nothing Then
        MsgBox "Aucune forme n'est sélectionnée!", vbCritical
    Else
        For Each shp In ActiveSheet.Shapes
            If shp Is obj Then
                MsgBox "Nom de forme sélectionnée: " & shp.Name, vbInformation
            End If
        Next
    End If
End Sub

Pour tester, insère une forme, sélectionne-la puis lance la macro
puis sélectionne une cellule et relance la macro

Staple1600 · 6 Octobre 2024

Bonsoir le fil

@Cédric06400
A adapter à tes besoins

VB:

Sub Test_AutoShape()
    Dim shp As Shape, obj As Object
    On Error Resume Next
    Set obj = Selection.ShapeRange(1)
    If obj Is Nothing Then
        MsgBox "Aucune forme n'est sélectionnée!", vbCritical
    Else
        For Each shp In ActiveSheet.Shapes
            If shp Is obj Then
                MsgBox "Nom de forme sélectionnée: " & shp.Name, vbInformation
            End If
        Next
    End If
End Sub

Pour tester, insère une forme, sélectionne-la puis lance la macro
puis sélectionne une cellule et relance la macro

Cédric06400 · 7 Octobre 2024

Staple1600 à dit:
Bonsoir le fil

@Cédric06400
A adapter à tes besoins

VB:

Sub Test_AutoShape() Dim shp As Shape, obj As Object On Error Resume Next Set obj = Selection.ShapeRange(1) If obj Is Nothing Then MsgBox "Aucune forme n'est sélectionnée!", vbCritical Else For Each shp In ActiveSheet.Shapes If shp Is obj Then MsgBox "Nom de forme sélectionnée: " & shp.Name, vbInformation End If Next End If End Sub

Pour tester, insère une forme, sélectionne-la puis lance la macro
puis sélectionne une cellule et relance la macro

Hello,
Merci pour ton retour rapide, c'est parfait.

Microsoft 365 Déplacement Shape

Cédric06400

XLDnaute Junior

Staple1600

Staple1600

XLDnaute Barbatruc

Cédric06400

XLDnaute Junior

Discussions similaires