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