Colocar 2 imágenes al cambiar el valor de una celda
Hace tiempo pregunté por aquí al respecto de una macro para que, según varía el valor de una celda, se colocara una imagen u otra. Además, esas imágenes se borran si la celda no tiene nada. A continuación os pego el código
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.DAM
If Not Intersect(Target, Range("D20:D40:V20:V40")) Is Nothing Then
On Error Resume Next
Me.Shapes("imagen1").Delete
Me.Shapes("imagen2").Delete
Me.Shapes("imagen3").Delete
Me.Shapes("imagen4").Delete
If Range("D20") <> "" Then
poner "D20", "C8:G19", "imagen1"
End If
If Range("D40") <> "" Then
poner "D40", "C28:G39", "imagen2"
End If
If Range("V20") <> "" Then
poner "V20", "U8:Y19", "imagen3"
End If
If Range("V40") <> "" Then
poner "V40", "U28:Y39", "imagen4"
End If
End If
End Sub
Sub poner(r1, r2, r3)
'Por.DAM
Application.ScreenUpdating = False
imagen = Range(r1) & ".png"
ruta = ActiveWorkbook.Path & "\personajes\" & imagen
Set clan = Me.Pictures.Insert(ruta)
With Range(r2)
Arriba = .Top
Izquierda = .Left
Ancho = .Offset(0, .Columns.Count).Left - .Left
Alto = .Offset(.Rows.Count, 0).Top - .Top
End With
With clan
.Name = r3
.Top = Arriba
.Left = Izquierda
.Width = Ancho
.Height = Alto
End With
Set clan = Nothing
Application.ScreenUpdating = False
End SubPongamos un ejemplo fácil. La celda A1 está vacía. Sin embargo si cambio y pongo 'Paco', en el rango de celdas A2:D5 sale la imagen de Paco. Si pongo 'Antonio', sale la imagen de Antonio. Si borro la celda y la vacío de contenido, la imagen se borra también. Eso es lo que hace esta macro ahora mismo (que como ya digo, me la enseñásteis vosotros)
He intentada modificarla por todos los medios para que añada una imagen más, fija, pero no he sido capaz. Es decir. Lo que quiero que haga es que cuando cambie el valor de A1, y ponga 'Paco', la imagen de Paco salga en A2:D5 y al mismo tiempo otra imagen se ponga en A10:D20. De ese modo se pondrían dos imágenes en lugar de una
El 'problema', además, radica en que la segunda imagen sería siempre la misma, es decir, NO dependería de lo que ponga en la celda A1. Tanto si pone 'Paco' como 'Antonio', la imagen es la misma. Y claro, en caso de que la celda A1 se vacíe de contenido y la borre, también debe desaparecer la imagen
¿Alguien puede echarme una mano y decirme cómo modifico esa macro?
1 Respuesta
H o l a:
Te anexo la macro actualizada.
En la celda A10, tienes que poner el nombre de la "imagen fija". Puede ser la celda A10 u otra celda, si vas a poner en el nombre de la "imagen fija" en otra celda, entonces tienes que cambiar "A10" en la macro, en estas líneas:
Poner "A10", "A10:D20", "imagen5"
También tienes que poner en esa línea de la macro, el rango de celdas en donde quieres que aparezca la imagen, yo puse "A10:D20", pero puedes poner el rango que necesites.
En la macro van 4 líneas iguales:
Poner "A10", "A10:D20", "imagen5"
Una línea para cada una de las 4 imágenes que cambias, entonces, puedes modificar la línea de cada imagen, por si tuvieras 4 "imágenes fijas".
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.DAM
If Not Intersect(Target, Range("D20,D40,V20,V40")) Is Nothing Then
On Error Resume Next
Me.Shapes("imagen1").Delete
Me.Shapes("imagen2").Delete
Me.Shapes("imagen3").Delete
Me.Shapes("imagen4").Delete
Me.Shapes("imagen5").Delete
If Range("D20") <> "" Then
poner "D20", "C8:G19", "imagen1"
poner "A10", "A10:D20", "imagen5"
End If
If Range("D40") <> "" Then
poner "D40", "C28:G39", "imagen2"
poner "A10", "A10:D20", "imagen5"
End If
If Range("V20") <> "" Then
poner "V20", "U8:Y19", "imagen3"
poner "A10", "A10:D20", "imagen5"
End If
If Range("V40") <> "" Then
poner "V40", "U28:Y39", "imagen4"
poner "A10", "A10:D20", "imagen5"
End If
End If
End Sub
Sub poner(r1, r2, r3)
'Por.DAM
Application.ScreenUpdating = False
imagen = Range(r1) & ".png"
ruta = ActiveWorkbook.Path & "\personajes\" & imagen
'ruta = ActiveWorkbook.Path & "\" & imagen
Set clan = Me.Pictures.Insert(ruta)
With Range(r2)
Arriba = .Top
Izquierda = .Left
Ancho = .Width
Alto = .Height
End With
With clan
.Name = r3
.Top = Arriba
.Left = Izquierda
.Width = Ancho
.Height = Alto
End With
Set clan = Nothing
Application.ScreenUpdating = False
End Sub
Wow, ¡hola Dante Amor!
¡Tú fuiste el que me ayudó con un par de macros para mi ficha de 'Vampiro', ¿recuerdas?! Cuando la publiqué agradecí tu colaboración públicamente en los foros, para que quedara constancia de que habías puesto tu granito de arena
Me alegra saber que continúas por aquí
La modificación de la macro que has hecho ha sido perfecta, sin problema ninguno. Únicamente me queda una pregunta por hacer, a ver si fuera posible: en la celda "A10" no quiero poner el nombre de la imagen fija, porque no quiero que se vea ningún texto. Así que he pensado que podría poner el nombre en otra hoja, en la que uso para las tablas, y así no se vería. ¿Es posible?
Ejemplo:
If Range("D20") <> "" Then
poner "D20", "C8:G19", "imagen1"
poner "Tablas!A10", "A10:D20", "imagen5"
He intentado así, pero parece ser que no termina de reconocer la dirección. No sé si la sintaxis para VB es incorrecta, pero me supongo que sí. Si pongo Tablas!"A10" me da un error de compilación, y si pongo como en el ejemplo, "Tablas!A10" la macro se compila bien pero no funciona y la imagen no sale
Quedaría así, agregué el parámetro del nombre de la hoja:
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.DAM
If Not Intersect(Target, Range("D20,D40,V20,V40")) Is Nothing Then
On Error Resume Next
Me.Shapes("imagen1").Delete
Me.Shapes("imagen2").Delete
Me.Shapes("imagen3").Delete
Me.Shapes("imagen4").Delete
Me.Shapes("imagen5").Delete
If Range("D20") <> "" Then
poner ActiveSheet.Name, "D20", "C8:G19", "imagen1"
poner "tablas", "A10", "A10:D20", "imagen5"
End If
If Range("D40") <> "" Then
poner ActiveSheet.Name, "D40", "C28:G39", "imagen2"
poner "tablas", "A10", "A10:D20", "imagen5"
End If
If Range("V20") <> "" Then
poner ActiveSheet.Name, "V20", "U8:Y19", "imagen3"
poner "tablas", "A10", "A10:D20", "imagen5"
End If
If Range("V40") <> "" Then
poner ActiveSheet.Name, "V40", "U28:Y39", "imagen4"
poner "tablas", "A10", "A10:D20", "imagen5"
End If
End If
End Sub
Sub poner(hoja, r1, r2, r3)
'Por.DAM
Application.ScreenUpdating = False
imagen = Sheets(hoja).Range(r1) & ".png"
ruta = ActiveWorkbook.Path & "\personajes\" & imagen
'ruta = ActiveWorkbook.Path & "\" & imagen
Set clan = Me.Pictures.Insert(ruta)
With Range(r2)
Arriba = .Top
Izquierda = .Left
Ancho = .Width
Alto = .Height
End With
With clan
.Name = r3
.Top = Arriba
.Left = Izquierda
.Width = Ancho
.Height = Alto
End With
Set clan = Nothing
Application.ScreenUpdating = False
End Sub
¡Gracias!
Como no podía ser de otro modo, perfecto. Dante Amor, eres un auténtico CRACK. Es posible que para ti estas cosas sean sencillas, pero no todo el mundo tiene tiempo para aprender ciertas cosas, y el hecho de que halla gente como tú, con tantos conocimientos y además dispuesto a compartirlos y ayudar es un privilegio
De nuevo gracias
