VBA copie d'une image à plusieurs endroits

Bonjour,

J'aimerais qu'une image se place à plusieurs cellules dans mon excel et sur différents onglets. Je ne sais pas comme écrire le code pour plusieurs onglets.

Voici mon code actuellement. Merci à l'avance

Sub CompressPicture()
Dim fName As String
Dim pic As Picture
Dim r As Range

fName = Application.GetOpenFilename( _
        FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
        Title:="Please select an image...")
If fName = "False" Then Exit Sub

Set r = Range("C80")
Set pic = Worksheets("Comparaison").Pictures.Insert(fName)

With pic
    .ShapeRange.LockAspectRatio = msoFalse
    .Left = r.Left
    .Top = r.Top
    .Width = r.Width
    .Height = r.Height
    .Select
End With

If TypeName(Selection) = "Picture" Then
    Application.SendKeys "%a~"
    Application.CommandBars.ExecuteMso "PicturesCompress"
End If
End Sub

Bonjour Alexcote, le forum,

Pas certain d'avoir compris le besoin....

Le code suivant insère une photo en C80, sur les 3 feuilles désignées.

Sub Image()
  Dim Image As Variant
  Dim L As Single, T As Single, W As Single, H As Single
  Dim Wsh As Worksheet

     Image = Application.GetOpenFilename( _
        FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
        Title:="Please select an image...")

     If fName = "False" Then Exit Sub

       For Each Wsh In Worksheets(Array("Feuil1", "Feuil2", "Feuil3")) 'nom de tes feuilles
        L = Wsh.Range("C80").Left  'cellule à adapter
        T = Wsh.Range("C80").Top
        W = Wsh.Range("C80").Width
        H = Wsh.Range("C80").Height

         On Error Resume Next
          Wsh.Shapes.AddPicture Image, True, True, L, T, W, H
        On Error GoTo 0
       Next Wsh
End Sub

CTRL + e pour exécuter la macro.

Cordialement,

C'est à peu près ça sauf que ce sera une case différente de C80 pour la 2e feuille. Pouvez-vous l'adapter ?

Re,

Peut-être ainsi :

Sub Image()
 Dim Image As Variant, i%
 Dim L As Single, T As Single, W As Single, H As Single
 Dim tb_feuille, tb_cellule

  Image = Application.GetOpenFilename( _
   FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
   Title:="Please select an image...")

   If fName = "False" Then Exit Sub
    tb_feuille = Array("Feuil1", "Feuil2", "Feuil3") 'nom des feuilles
    tb_cellule = Array("C80", "B60", "A40") ' cellules correspondantes

     For i = LBound(tb_feuille) To UBound(tb_feuille)
      On Error Resume Next
       L = Sheets(tb_feuille(i)).Range(tb_cellule(i)).Left
       T = Sheets(tb_feuille(i)).Range(tb_cellule(i)).Top
       W = Sheets(tb_feuille(i)).Range(tb_cellule(i)).Width
       H = Sheets(tb_feuille(i)).Range(tb_cellule(i)).Height
       Sheets(tb_feuille(i)).Shapes.AddPicture Image, True, True, L, T, W, H
      On Error GoTo 0
     Next i
End Sub

Cordialement,

Merci, j'ai dû modifié quelques peu. Ca fonctionne bien maintenant. Voici le code. Merci beaucoup.

Sub Image()
Dim fName As String
 Dim Image As Variant, i%
 Dim L As Single, T As Single, W As Single, H As Single
 Dim tb_feuille, tb_cellule

  Image = Application.GetOpenFilename( _
   FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
   Title:="Please select an image...")

   If fName = "False" Then Exit Sub
    tb_feuille = Array("Comparaison", "registre comparables") 'nom des feuilles
    tb_cellule = Array("C80", "B3") ' cellules correspondantes

     For i = LBound(tb_feuille) To UBound(tb_feuille)
      On Error Resume Next
       L = Sheets(tb_feuille(i)).Range(tb_cellule(i)).Left
       T = Sheets(tb_feuille(i)).Range(tb_cellule(i)).Top
       W = Sheets(tb_feuille(i)).Range(tb_cellule(i)).Width
       H = Sheets(tb_feuille(i)).Range(tb_cellule(i)).Height
       Sheets(tb_feuille(i)).Shapes.AddPicture Image, True, True, L, T, W, H
      On Error GoTo 0
     Next i
End Sub