Macro fijar foto en cada celda
Es un gusto saludarlos nuevamente.
Tengo la siguiente macro, pero cada vez que la utilizo para pegar fotos (> 200 fotos) a partir de la fila 8 (+/-) las fotos no quedan fijas en cada celda y estas se comienzan a desplazar hacia la fila siguiente. Tengo Office 2007.
Sub im4()
'Por.Dante Amor
ruta = "C:\trabajo\varios\"
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
arch = Dir(ruta & Cells(i, "B") & ".jp*")
If arch <> "" Then
With Cells(i, "A")
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
.Left = Izquierda
.Width = Ancho
.Height = Alto
End With
Set fotografia = Nothing
End If
Next
End Sub
1 Respuesta
Este código que tengo esta fijado "mirando" a la celda que le indiques:
ActiveSheet.DrawingObjects.Delete
ruta = "C:\trabajo\varios\"' aca indica la fila A que es donde esta el nombre de donde obtiene la foto
For i = 2 To Range("a" & Rows.Count).End(xlUp).Row
imagen = Cells(i, "a")
Dim Archivo As String
Archivo = ruta & imagen & ".jpg"
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(Archivo) Then
Set img = Excel.ActiveSheet.Pictures.Insert(ruta & imagen & ".jpg")
Else
Set img = Excel.ActiveSheet.Pictures.Insert(ruta & "no image" & ".jpg")
End If' Acá indica AC que es donde va a poner la foto. Las dimensiones de la foto las saca del tamaño de la celda.
With Cells(i, "AC")
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
Este código nunca me dio ningún tipo de problemas y lo uso con reportes bastantes extensos.
Avisa cualquier cosa.
¡Gracias!
De nada! Me olvide aclararte que en caso de que no encuentre la foto pone una foto suplente llamada "no image".
