Microsoft 365 Macro qui plante exel

Bonjour,

J’espère que quelqu’un sera en mesure de m'aider.

J'ai créé une macro qui me permet de copier coller une image a un ou plusieurs endroit en même temps lorsque j'appuie sur un bouton contrôle de formulaire.

Tout fonctionnais bien jusqu’à présent cependant maintenant si je sélectionne deux emplacement pour la meme image cela me fait planter exel.

Quelq'un peut il m'aider s'il vous plait ?

Merci d'avance,

Cordialement,



Sub signature_freuze()
'
' signature_freuze Macro
'

'
Dim mdp As String
Dim key As String

key = "0000"
mdp = InputBox("Entrez le mot de passe")
If mdp = key Then


If Range("G5") = "FREUZE" Then
Range("H5:H6").Select
Sheets("Data").Select
ActiveSheet.Shapes.Range(Array("Image 15")).Select
Selection.Copy
Sheets("mensuel CP").Select
ActiveSheet.Paste
Selection.ShapeRange.ScaleWidth 1.3757946698, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1.512295658, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.IncrementLeft 7.5
Selection.ShapeRange.IncrementTop 3.2143307087
End If

If Range("I5") = "FREUZE" Then
Range("J5:J6").Select
Sheets("Data").Select
ActiveSheet.Shapes.Range(Array("Image 15")).Select
Selection.Copy
Sheets("mensuel CP").Select
ActiveSheet.Paste
Selection.ShapeRange.ScaleWidth 1.1684838462, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1.5567744614, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.IncrementLeft 9.6428346457
Selection.ShapeRange.IncrementTop 2.1429133858
End If

If Range("I10") = "FREUZE" Then
Range("I11:J11").Select
Sheets("Data").Select
ActiveSheet.Shapes.Range(Array("Image 15")).Select
Selection.Copy
Sheets("mensuel CP").Select
ActiveSheet.Paste
Selection.ShapeRange.ScaleWidth 1.5265679406, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1.2009374969, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.IncrementLeft 43.9285826772
Selection.ShapeRange.IncrementTop 1.071496063
End If

Else: MsgBox "Mot de passe erroné Accès refusé"

End If




End Sub