VBA Copier une image dans un nouveau Excel

Sub Copy_Paste_Below_Last_Cell()

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

  Set wsCopy = ThisWorkbook.Worksheets("Registre Comparables")
  Set wsDest = Workbooks("Registre test.xlsm").Worksheets("eval")

Workbooks("Excel test.xlsm").Worksheets("Copie des comparables").Range("B3:BD7").Copy _

  lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row

  wsCopy.Range("B3:BD7" & lCopyLastRow).Copy
    wsDest.Range("A" & lDestLastRow).PasteSpecial xlPasteValues, SkipBlanks:=True

      ActiveSheet.Range("A2:BC" & lDestLastRow).RemoveDuplicates Columns:=Array(2), Header:=xlYes

  wsDest.Activate

  On Error Resume Next

  Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

Bonjour Alexcote,

Un extrait du fichier serait le bienvenu , les photos sont, sous forme de lien ? présentes physiquement (donc insérées en tant qu'image, donc pas contenues dans une cellule et donc pas copiées ...) ?

Nota : lCopyLastRow est défini et utilisé mais pas initialisé

Bonjour,

Pour Copylastrow, j'ai peu de ne pas comprendre (je suis plutôt nouveau à ce jeu :))

Voici le code de provenance des photos, il y a un code comme celui-là pour chaque photo :

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

Bonjour,

Si tu ne peux pas fournir un extrait de ton ou tes fichiers, je ne pourrais pas te répondre avec plus précision.

Je te joins un exemple pour copier les images contenues dans l'onglet nommé "Onglet source" du classeur contenant la macro vers l'onglet nommé "Onglet cible" d'un autre classeur (ouvert) nommé "ClasseurDeDestination.xlsx".

A adapter à tes besoins.

Sub CopierImage()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim objTmp As Shape
Dim nI As Long

   Set wsSource = ThisWorkbook.Worksheets("Onglet Source")
   Set wsDest = Workbooks("ClasseurDeDestination.xlsx").Worksheets("Onglet Cible")

   With wsSource
      nI = 0
      For Each objTmp In .Shapes
         ' Si le type d'objet est une image on la copie
         If (objTmp.Type = msoLinkedPicture) Or (objTmp.Type = msoPicture) Then
            nI = nI + 1
            ' Copie de l'image source
            objTmp.Copy
            ' Collage de l'image aux coordonnées (top et left) de la cellule cible
            wsDest.Paste Destination:=wsDest.Range("B" & nI * 2)
         End If
      Next
   End With
End Sub

Pour la remarque sur la variable : tu as défini Dim lCopyLastRow As Long que tu utilises dans wsCopy.Range("B3:BD7" & lCopyLastRow).Copy mais cette variable n'est jamais initialisée, donc elle vaut zéro et par conséquent la destination est toujours "B3:BD70". C'est peut-être lié à une copie partielle du code ...