Extraer imagenes a excel de una carpeta con VBA

[renato13]

Buenas noche amigos me gustarian que me den una ayuda he encontrado en el internel un código para extraer imágenes a excel desde una carpeta pero quiero mejorar. La idea es; tengo una carpeta de imagenes y quiero desde excel  digitar el código (código de la carpeta origen) en una celda "A2"que tiene un combobox y que la imágen aparezca en la "B2" con dimensiones predeterminadas y al digitar el siguiente código en la celda "A3" se cargue la imágen en "B3" y así sucesivamente porque quiero mandar esto por un correo.

Le adjunto el archivo para que ayuden amigos. Gracias por su tiempo

Demo2.0.xlsmFetching info...

[Antoni]

En la hoja:

Private Sub Worksheet_Change(ByVal Target As Range)
'---------------------------------
'Inserta la imagen de la columna A
'---------------------------------
If Target.Address Like "$A$*" Then InsertarImagen Target
End Sub

En un módulo:

Sub InsertarImágenes()
'--------------------------
'Inserta todas las imágenes
'--------------------------
Dim x As Long
For x = 8 To Range("A" & Rows.Count).End(xlUp).Row
   InsertarIagen Range("A" & x)
Next
End Sub
'-------------------------------------------------------
Sub InsertarImagen(Imagen As Range): On Error Resume Next
Dim Archivo As String
'------------------
'Inserta una imagen
'------------------
Application.ScreenUpdating = False
ActiveSheet.Shapes(Imagen.Address).Delete
Imagen = ThisWorkbook.Path & "\Coches\" & Imagen.Value & ".jpg"
ActiveSheet.Pictures.Insert(Archivo).Select
With Selection.ShapeRange
   .LockAspectRatio = False
   .Name = Imagen.Address
   .Top = Imagen.Offset(0, 1).Top
   .Left = Imagen.Offset(0, 1).Left
   .Width = Imagen.Offset(0, 1).Width
   .Height = Imagen.Offset(0, 1).Height
End With
ActiveCell.Select
Application.ScreenUpdating = True
End Sub

No me queda claro si también quieres obtener la lista de las imágenes de la carpeta Coches para luego validar la columna A.

[renato13]

Hola Antoni, parece que no plantié bien mi problema; quiero que mediante un combobox o cuadro desplegable que está en la celda de la columna "A" escoger el codigo en este caso un color y debe aparecer o extraer la imagen que están en una carpeta y si tecleo otro color en la siguiente celda de la columna a aparecerá otro auto y si solo hay el codigo y no la imagen deveria quedar el espcio en blanco para saber que no hubo imagen de ese color (código) osea en cada celda de "A" deberia haver un cuadro desplegable para escoger los valores que se cargan de la carpeta de imagenes y que aparezcan el la celda "B".

Espero fui ahora un poco mas explicito, muchas gracias por tu tiempo

[renato13]

  En 14/9/2020 at 9:36 , Antoni dijo:

En la hoja:

Private Sub Worksheet_Change(ByVal Target As Range)
'---------------------------------
'Inserta la imagen de la columna A
'---------------------------------
If Target.Address Like "$A$*" Then InsertarImagen Target
End Sub

En un módulo:

Sub InsertarImágenes()
'--------------------------
'Inserta todas las imágenes
'--------------------------
Dim x As Long
For x = 8 To Range("A" & Rows.Count).End(xlUp).Row
   InsertarIagen Range("A" & x)
Next
End Sub
'-------------------------------------------------------
Sub InsertarImagen(Imagen As Range): On Error Resume Next
Dim Archivo As String
'------------------
'Inserta una imagen
'------------------
Application.ScreenUpdating = False
ActiveSheet.Shapes(Imagen.Address).Delete
Imagen = ThisWorkbook.Path & "\Coches\" & Imagen.Value & ".jpg"
ActiveSheet.Pictures.Insert(Archivo).Select
With Selection.ShapeRange
   .LockAspectRatio = False
   .Name = Imagen.Address
   .Top = Imagen.Offset(0, 1).Top
   .Left = Imagen.Offset(0, 1).Left
   .Width = Imagen.Offset(0, 1).Width
   .Height = Imagen.Offset(0, 1).Height
End With
ActiveCell.Select
Application.ScreenUpdating = True
End Sub

No me queda claro si también quieres obtener la lista de las imágenes de la carpeta Coches para luego validar la columna A.

Expand  

Option Explicit

Sub InsertarImagenes_2shapes()

'Declaramos variables
Dim RutaActual As String
Dim RangoImagen As Range
Dim shp As Object
Dim RutaCompleta

'On Error GoTo ManejadorErrores

On Error Resume Next

For Each shp In ActiveSheet.Shapes
    If shp.Name = "ImagenUno" Then
    Else
        shp.Delete
    End If
Next

'La variable RutaActual guardará la ruta completa donde está el archivo
RutaActual = ThisWorkbook.Path

'Desactivamos la actualización de pantalla
Application.ScreenUpdating = False

'Elegimos la celda B3
ActiveSheet.Range("B59").Select

'Recorremos cada fila mientras haya datos en la columna A
Do While ActiveCell.Offset(0, -1).Value <> Empty
    
    Set RangoImagen = ActiveCell.Offset(0, -1)
    
    'Insertamos la imagen que corresponda al nombre de la columna A
    'ActiveSheet.Pictures.Insert(RutaActual & "\Coches\" & RangoImagen.Value & ".jpg").Select
    ''''''''''''''''''''''''''''''''''''''''
    RutaCompleta = RutaActual & "\Coches\" & RangoImagen.Value & ".jpg"
    With ActiveSheet.Shapes.AddPicture(Filename:=RutaCompleta, linktofile:=msoFalse, _
        SaveWithDocument:=msoCTrue, Left:=0, Top:=0, Width:=-1, Height:=-1)
        .LockAspectRatio = 0
        .Top = ActiveCell.Top
        .Left = ActiveCell.Left
        .Width = ActiveCell.Width
        .Height = ActiveCell.Height
    End With
    ''''''''''''''''''''''''''''''''''''''''
    
    'Activamos la siguiente fila
    ActiveCell.Offset(1, 0).Select
    
Loop

Range("A2").Select
Application.ScreenUpdating = True

'Call FitPic

'Exit Sub

'ManejadorErrores:

'MsgBox "Ha ocurrido un Error: " & Err.Description, vbExclamation

On Error GoTo 0

End Sub

Hola Antoni estuve probando de otra forma más fácil si en la celda "A2" digito el código de la imágen para que aparezca en la celda "B2" pero cuando no hay imagen deberia dejar la celda en blanco donde va la imagen y seguir la macro si pongo otro codigo en la "B3" deberia salir o continuar. No puedo con los manejadores de errores hacer que continue poniendo imagenes a pesar que en celdas anteriores solo haya el codigo y no imagenes.

No se si te orienté más de lo que quiero hacer gracias