Como insertar imagenes automaticamente EXCEL

Para Dante Amor.

Buenas tardes.

Hace algún tiempo me facilitó una macro estupenda, saca las imágenes directamente de cada tarifa y luego las puedo insertar, sin problema en otras, con la otra macro, pero me ha surgido un problema que no había controlado, y seguramente sea algo sencillo de solucionar.

Cuando extraigo las imágenes lo hace de algún modo que después al insertarlas si borro la carpeta que contiene los ficheros de las imágenes me aparece esto en lugar de la imagen. Es como si no la localizase. "No se puede mostrar la imagen vinculada. Puede que se haya movido cambiado de nombre o eliminado..."

En cambio si pongo la imagen sin haberla conseguido extrayendola con la macro la mantiene en su tamaño, intentar y lugar.

¿Se podría reparar esto de algún modo?

Lo que necesito es poder hacer tarifas personalizadas y enviarlas a mis clientes, pero que vean las imágenes.

La macros que me enviaron son estas, una para EXTRAER y otra para INSERTAR.

Macro extraer imagen.

Sub CopiarCeldasComoImagen()
'Por.Dante Amor
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set h1 = Sheets("hoja2") 'hoja con las imágenes
Set h2 = Sheets("temp") 'hoja temporal
h2.Cells.Clear
ruta = "C:\Users\comercial6\Documents\Nueva carpeta\" 'ruta destino de los archivos
'
For i = 2 To h1.Range("B" & Rows.Count).End(xlUp).Row
h2.DrawingObjects.Delete
nom = h1.Cells(i, "B")
For Each img In h1.DrawingObjects
top_ini = h1.Cells(i, "B").Top
top_fin = h1.Cells(i + 1, "B").Top
top_img = img.Top
If top_img >= top_ini And top_img <= top_fin Then
h1.Select
img.Select
anc = img.Width
alt = img.Height
Selection.Copy
archivo = nom & ".jpeg"
'
h2.Shapes.AddChart
With h2.ChartObjects(1)
.Width = anc
.Height = alt
.Chart.Paste
.Chart.Export ruta & archivo
.Delete
End With
Exit For
End If
Next
Next
'
Application.DisplayAlerts = True
MsgBox "Imágenes exportadas "
End Sub

MACRO INSERTAR IMAGEN.

Sub InsertarImagenes()
'Por.Dante Amor
Application.ScreenUpdating = False
ActiveSheet.DrawingObjects.Delete
u = Range("A" & Rows.Count).End(xlUp).Row
Rows("1:" & u).RowHeight = 74.5 '60
Columns("B:B").ColumnWidth = 22.29 '15
ruta = ThisWorkbook.Path & "\imagenes\"
For i = 1 To u
arch = Dir(ruta & Cells(i, "A") & ".*")
If arch <> "" Then
With Cells(i, "B")
Arriba = .Top + 1
izquierda = .Left + 1
ancho = .Width - 2
Alto = .Height - 2
End With
'
Set fotografia = ActiveSheet.Pictures.Insert(ruta & arch)
With fotografia
.Placement = xlMoveAndSize
.ShapeRange.LockAspectRatio = msoFalse
.Top = Arriba
img_ancho = .Width
res = (ancho - img_ancho) / 2
.Left = izquierda + res
'.Left = Izquierda
'.Width = Ancho
'.Height = Alto
End With
Set fotografia = Nothing
End If
Next
Application.ScreenUpdating = True
MsgBox "Imágenes insertadas"
End Sub

Respuesta
2

No sé qué pasa, tal vez es tu versión de excel. Te comento los pasos que hice.

- Abro el archivo 1.

- Ejecuto la macro para extraer las imágenes en la carpeta "img_ext"

- Cierro el archivo 1

- Abro el archivo 2, no tiene imágenes

- Ejecuto la macro para importar imágenes desde la carpeta "img_ext"

- Las imágenes se cargan en la hoja.

- Guardo el archivo 2

- Cierro el archivo 2

- Elimino la carpeta "img_ext" con todo y las imágenes

- Abro el archivo 2 y ahí están las imágenes.

Prueba en otra computadora con otra versión de excel

Sa l u dos

¡Gracias! Sr. Amor.

Si que es cierto que he cambiado a Excel 2010, podria ser el problema?

Prueba con una máquina que tenga excel 2007.

Le hice unos ajustes a la macro

Sub InsertarImagenes()
'Por.Dante Amor
    Application.ScreenUpdating = False
    ActiveSheet.DrawingObjects.Delete
    u = Range("A" & Rows.Count).End(xlUp).Row
    Rows("1:" & u).RowHeight = 74.5 '60
    Columns("B:B").ColumnWidth = 22.29 '15
    'ruta = ThisWorkbook.Path & "\imagenes\"
    ruta = ThisWorkbook.Path & "\img_ext\"                       'ruta destino de los archivos
    For i = 1 To u
        arch = Dir(ruta & Cells(i, "A") & ".*")
        If arch <> "" Then
            With Cells(i, "B")
                Arriba = .Top + 1
                izquierda = .Left + 1
                ancho = .Width - 2
                Alto = .Height - 2
            End With
            '
            Set fotografia = ActiveSheet.Pictures.Insert(ruta & arch)
            With fotografia
                .Copy
                .Delete
                ActiveSheet.Paste
            End With
            With Selection
                .Placement = xlMoveAndSize
                .ShapeRange.LockAspectRatio = msoFalse
                .Top = Arriba
                img_ancho = .Width
                res = (ancho - img_ancho) / 2
                .Left = izquierda + res
                '.Left = Izquierda
                '.Width = Ancho
                '.Height = Alto
            End With
            Set fotografia = Nothing
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Imágenes insertadas"
End Sub

R ecuerda valorar la respuesta.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas