Copia una imagen inserta en una hoja de excel y centrarla en una celda determinada
Tengo una imagen inserta en una hoja llamada TITULOS y teniendo una celda "A1" (de un tamaño superior) en otras hojas (ELECTRICO, MECANICO), quiero realizar un copia pega y centrado de esta imagen a dicha celda en estas dos hojas...
Aceptais este reto
1 respuesta
Te anexo la macro para copiar la imagen. Cambia en la macro "1 Imagen", por el nombre de tu imagen, para que conozcas el nombre de tu imagen que tienes en la hoja "TITULOS", simplemente selecciona la imagen y en el cuadro de nombres aparece el nombre, ejemplo:
Ya que tienes el nombre reemplaza en la macro en estas 2 líneas "1 Imagen", por el nombre de tu imagen
anc1 = h1.Shapes("1 Imagen").Width
alt1 = h1.Shapes("1 Imagen").Height
Sub CopiarImagen()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("TITULOS")
anc1 = h1.Shapes("1 Imagen").Width
alt1 = h1.Shapes("1 Imagen").Height
'
hojas = Array("ELECTRICO", "MECANICO")
For h = LBound(hojas) To UBound(hojas)
Set h2 = Sheets(hojas(h))
anc2 = h2.[A1].Width
alt2 = h2.[A1].Height
top2 = h2.[A1].Top
lef2 = h2.[A1].Left
'
If anc2 > anc1 Then
difanc = (anc2 - anc1) / 2
Else
difanc = 0
End If
If alt2 > alt1 Then
difalt = (alt2 - alt1) / 2
Else
difalt = 0
End If
'
h1.Shapes("1 Imagen").Copy
h2.Select
ActiveSheet.Paste
Selection.Top = top2 + difalt
Selection.Left = lef2 + difanc
Next
MsgBox "Copia Imagen Terminada", vbInformation
End SubSigue las Instrucciones para un botón y ejecutar la macro
- Abre tu libro de Excel
- Para abrir Vba-macros y poder pegar la macro, Presiona Alt + F11
- En el menú elige Insertar / Módulo
- En el panel del lado derecho copia la macro
- Ahora para crear un botón, puedes hacer lo siguiente:
- Inserta una imagen en tu libro, elige del menú Insertar / Imagen / Autoformas
- Elige una imagen y con el Mouse, dentro de tu hoja, presiona click y arrastra el Mouse para hacer grande la imagen.
- Una vez que insertaste la imagen en tu hoja, dale click derecho dentro de la imagen y selecciona: Tamaño y Propiedades. En la ventana que se abre selecciona la pestaña: Propiedades. Desmarca la opción “Imprimir Objeto”. Presiona “Cerrar”
- Vuelve a presionar click derecho dentro de la imagen y ahora selecciona: Asignar macro. Selecciona: CopiarImagen
- Aceptar.
- Para ejecutarla dale click a la imagen.
Saludos. Dante Amor
Este código me genera un error, igual me he explicado mal, la imagen la he llamado LOGO, esta en l a hoja TITULOS y quiero que la coloque en la celda A1, solo a las hojas que empiezan por "REPUESTOS" y les voy dando formato con el siguiente código...aquí es donde me interesaría que realizase el copiado y pegado por cada hoja ("REPUESTOS" de la imagen LOGO en las celdas "A1"
For Each HOJA In Sheets
If Left(HOJA.Name, 9) = "REPUESTOS" Then
Debug.Print HOJA.Name
HOJA.Select
'damos la medida a las 3 primeras columnas
Cells(1, 1).EntireRow.RowHeight = 36 'altura fila1
Cells(1, 1).EntireColumn.ColumnWidth = 13 'ancho columna1
Cells(1, 2).EntireColumn.ColumnWidth = 68 'ancho columna2
Cells(1, 3).EntireColumn.ColumnWidth = 40 'ancho columna3
'aquí interesaría meter la instrucción del pegado de LOGO
Next HOJA
End Sub
Gracias por vuestro asesoramiento...gracias no...muchísimas gracias
Saludos
Ahora ya no entendí qué es lo que necesitas.
Envíame tu archivo y con colores y comentarios me explicas paso a paso qué quieres que haga la macro.
Mi correo jov19p3@yahoo.com
En el asunto del correo escribe tu nombre de usuario "valdokken" y el título de esta pregunta.
Te anexo la macro para que busque la palabra "REPUESTOS" en cada hoja, si encuentra varias, a cada una en la columna A, le va a pegar la imagen, así para todas las hojas.
Sub CopiarImagen()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("TITULOS")
anc1 = h1.Shapes("FAURECIA").Width
alt1 = h1.Shapes("FAURECIA").Height
'
For Each h2 In Sheets
If h2.Name <> "TITULOS" Then
Set r = h2.Columns("B")
Set b = r.Find("REPUESTOS", lookat:=xlPart)
If Not b Is Nothing Then
ncell = b.Address
Do
With h2.Range("A" & b.Row)
anc2 = .Width
alt2 = .Height
top2 = .Top
lef2 = .Left
End With
'
difanc = 0
difalt = 0
If anc2 > anc1 Then difanc = (anc2 - anc1) / 2
If alt2 > alt1 Then difalt = (alt2 - alt1) / 2
'
h1.Shapes("FAURECIA").Copy
h2.Select
ActiveSheet.Paste
Selection.Top = top2 + difalt
Selection.Left = lef2 + difanc
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
End If
Next
MsgBox "Copia Imagen Terminada", vbInformation
End SubEl problema con la macro, o más bien, con esta lógica, es que si encuentra la palabra "REPUESTOS" en la descripción , también le va a poner la imagen.
Lo que te recomiendo para, no hacer una macro tan compleja, como la que te estoy enviando, lo más simple es, cuando copies la fila con el formato, copia la fila entera, de esa forma también se copia la imagen, por ejemplo:
Sub CopiarFormatoConImagen()
'Por.Dante Amor
Set h1 = Sheets("TITULOS")
h1.Rows(1).Copy ActiveSheet.Range("A" & ActiveCell.Row)
End SubY así de sencillo, solamente posiciona el cursor en la fila que quieres copiar el formato y ejecuta la macro. La macro copiará toda la fila incluida la imagen.
Saludos. Dante Amor
