Catalogo de imágenes con macro
Tengo un archivo que contiene ciertos datos y lo que deseo es insertar imágenes que hacen referencia a una celda. La idea es de que en cada celda "N" vaya una foto que poseo en una carpeta llamada "imagenes" alojada en el mismo directorio que mi archivo Excel. Estoy intentando que me lea la celda "E" que es donde tengo el nombre de la imagen y la inserte en "N" pero no logro ni siquiera insertar una sola imagen. Encontré en varios ejemplos pero no logro hacer que funcione.
Les paso un ejemplo de lo que adapte:
Sub ponerimagenes() On Error Resume Next ruta = ThisWorkbook.Path & "\Imagenes\" imagen = [e2] Set img = ActiveSheet.Pictures.Insert(ruta & imagen) With [N2] Arr = .Top Izq = .Left Anc = .Width Alt = .Height End With With img .ShapeRange.LockAspectRatio = msoFalse .Top = Arr .Left = Izq .Width = Anc .Height = Alt End With Set img = Nothing End Sub
Alguna sugerencia?
Aclaración: La hoja tiene encabezado. La macro debería recorrer la columna E e insertar las imágenes en N.
1 Respuesta
H o l a:
Está bien tu macro, solamente tienes que poner bien el nombre de la imagen con todo y extensión. Revisa si la extensión es jpg o jpeg
Te anexo la macro actualizada para que lea todas los nombres de la columna "E"
Sub ponerimagenes()
'Act.Por.Dante Amor
ActiveSheet.DrawingObjects.Delete
ruta = ThisWorkbook.Path & "\" '& "\Imagenes\"
'
For i = 2 To Range("E" & Rows.Count).End(xlUp).Row
imagen = Cells(i, "E")
Set img = ActiveSheet.Pictures.Insert(ruta & imagen)
With [N2]
Arr = .Top
Izq = .Left
Anc = .Width
Alt = .Height
End With
With img
.ShapeRange.LockAspectRatio = msoFalse
.Top = Arr
.Left = Izq
.Width = Anc
.Height = Alt
End With
Set img = Nothing
Next
End SubS a l u d o s . D a n t e A m o r. Recuerda valorar la respuesta.
Hola Dante, gracias por tu respuesta, me da un error la macro en la siguiente línea:
Set img = ActiveSheet.Pictures.Insert(ruta & imagen)
Me dice que no se puede obtener la propiedad Insert de la clase Pictures. No entiendo porque. En la línea que dice:
ruta = ThisWorkbook.Path & "\" '& "\Imagenes\"
deje:
ruta = ThisWorkbook.Path & "\Imagenes\"
esto no afectaria. Verifique y la imagen existe. La extension es JPG, va declarada en esta linea, no?
imagen = Cells(i, "E") & ".jpg"
Gracias por la ayuda.
Dante, disculpa la molestia, estuve "tocando" el código y vi que así si me funciona:
Sub ponerimagenes()
'Act.Por.Dante Amor
ActiveSheet.DrawingObjects.Delete
ruta = ThisWorkbook.Path & "\Imagenes\"
'
For i = 2 To Range("E" & Rows.Count).End(xlUp).Row
imagen = Cells(i, "E")
Set img = Excel.ActiveSheet.Pictures.Insert(ruta & imagen & ".jpg")
With [N2]
Arr = .Top
Izq = .Left
Anc = .Width
Alt = .Height
End With
With img
.ShapeRange.LockAspectRatio = msoFalse
.Top = Arr
.Left = Izq
.Width = Anc
.Height = Alt
End With
Set img = Nothing
Next
End Sub
El tema es que las imágenes ahora me quedan todas metidas en N2, en vez de poner cada imagen en la misma celda de la consulta...
Tienes razón, me faltó indicarle el número de fila.
Te anexo la macro actualizada
Sub ponerimagenes()
'Act.Por.Dante Amor
ActiveSheet.DrawingObjects.Delete
ruta = ThisWorkbook.Path & "\Imagenes\"
'
For i = 2 To Range("E" & Rows.Count).End(xlUp).Row
imagen = Cells(i, "E")
Set img = Excel.ActiveSheet.Pictures.Insert(ruta & imagen & ".jpg")
With Cells(i, "N")
Arr = .Top
Izq = .Left
Anc = .Width
Alt = .Height
End With
With img
.ShapeRange.LockAspectRatio = msoFalse
.Top = Arr
.Left = Izq
.Width = Anc
.Height = Alt
End With
Set img = Nothing
Next
End SubS a l u d o s . D a n t e A m o r. Recuerda valorar la respuesta.
