¿Cómo vincular una imagen con un valor de celda?
Saludos Maestro. He visto que existe un modelo y una explicación sobre esta pregunta pero yo quisiera que se visualice de otra forma. Primeramente quiero agradecer por compartir tus conocimientos. Tengo un pedido como hago para que no sea necesario que pulse el botón de macro para que se ejecute, sino mas bien que sea automático; es decir, en la celda A1 cambio el nombre de la imagen automáticamente se visualice. Y otra cosa más como hago para que la imagen saque directamente de la carpeta actual y no de "c:\trabajo\". Gracias por la ayuda.
1 Respuesta
Para que funcione en automático, pon la macro en los eventos de tu hoja
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
If Not Intersect(Target, Range("A1")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
'Nombre de la carpeta
carpeta = ThisWorkbook.Path & "\"
'Nombre de la foto
img = Range("A1")
'Celda para poner la foto
With Range("B1")
arr = .Top
izq = .Left
anc = .Width
alt = .Height
End With
archivo = carpeta & img
If Dir(archivo) <> "" Then
ActiveSheet.Pictures.Insert(archivo).Select
With Selection
.Placement = xlMoveAndSize
.PrintObject = True
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Top = arr
.ShapeRange.Left = izq
.ShapeRange.Height = alt
.ShapeRange.Width = anc
.ShapeRange.Rotation = 0#
End With
Else
MsgBox "imagen no existe"
End If
Target.Select
End If
End SubSaludos.Dante Amor
Gracias Maestro por tan pronta contestación. Solo un par de cositas. Primero quiero que en la celda A1 esta el nombre del archivo que esta cogido con "control de número"
cabe recordar que las fotos esta numeradas. La macro se funciona pero escribiendo manualmente en la celda A1. El otro problema es que cuando cambio de imagen la anterior no se borra sino mas bien que se va sobreponiendo una encima de otra. Gracias por la tremenda ayuda.
Te anexo la macro para que no encime las imágenes.
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
If Not Intersect(Target, Range("A1")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
'Nombre de la carpeta
carpeta = ThisWorkbook.Path & "\"
'Nombre de la foto
img = Range("A1")
'Celda para poner la foto
With Range("B1")
arr = .Top
izq = .Left
anc = .Width
alt = .Height
End With
archivo = carpeta & img
If Dir(archivo) <> "" Then
On Error Resume Next
ActiveSheet.Pictures("imagen").Delete
On Error GoTo 0
ActiveSheet.Pictures.Insert(archivo).Select
With Selection
.Name = "imagen"
.Placement = xlMoveAndSize
.PrintObject = True
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Top = arr
.ShapeRange.Left = izq
.ShapeRange.Height = alt
.ShapeRange.Width = anc
.ShapeRange.Rotation = 0#
End With
Else
MsgBox "imagen no existe"
End If
Target.Select
End If
End Sub
