Copiar una Gráfica como imagen para reemplazarla en el mismo lugar con una Macro de Excel 2016 y sea aplicable a varias Hojas
Tengo un grupo de datos, los cuales generan una gráfica, para entregar los resultados sin que incluya fórmulas o macros además de cambiar la extensión del archivo de xlsm a xlsx, a los datos los copio y pego en el mismo lugar como valores y las gráficas las copio, pego como una imagen, borro la gráfica y coloco la imagen en el mismo lugar de la gráfica, en la macro funciona bien el copiar y pegar valores pero las gráficas no, yo supongo sea por que las gráficas y las imágenes las crea con nombres diferentes cada vez; ejemplo Gráfico 12, Picture 1 y se detiene la Macro y no puede continuar, mis hojas se nombran Referencia Lunes, Referencia Martes, etc., espero cualquier idea que gusten compartir y gracias de antemano por la ayuda
1 respuesta
H o l a : Te anexo la macro para revisar todas las hojas.
Pon los nombres de las hojas a revisar en esta parte:
Hojas = Array("Referencia Lunes", "Referencia Martes", "Referencia Miercoles")No importa cómo se llame el gráfico, la macro lo va a encontrar, a copiar y a pegar como imagen.
La macro:
Sub For_Val_Met()
'Act.Por.Dante Amor
Application.ScreenUpdating = False
hojas = Array("Referencia Lunes", "Referencia Martes", "Referencia Miercoles")
For h = LBound(hojas) To UBound(hojas)
'
Sheets(hojas(h)).Select
Range("G6:H6"). Copy
Range("G6"). PasteSpecial xlPasteValues
Range("C10:I33"). Copy
Range("C10"). PasteSpecial xlPasteValues
'
For Each obj In ActiveSheet.DrawingObjects
nombre = obj.Name
If InStr(1, UCase(nombre), "GRÁFICO") > 0 Then
ActiveSheet.ChartObjects(nombre).Activate
izq = Selection.Left
arr = Selection.Top
ActiveChart.ChartArea.Copy
Range("C10").Select
ActiveSheet.Pictures.Paste.Select
Selection.Left = izq
Selection.Top = arr
ActiveSheet.ChartObjects(nombre).Delete
Exit For
End If
Next
Next
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Fin"
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Hola, muchas gracias por contestar, te lo agradezco en demasía , valoro mucho tu esfuerzo y el consejo que me diste, coloqué los nombres del resto de las hojas apliqué la macro y funcionó muy bien toda la parte del reemplazo de datos, aparece el mensaje de Fin, pero a las Gráficas no les hizo nada, no se copiaron o reemplazaron, quedo atento a tus comentarios, saludos.
Sub For_Val_Met()
'Act.Por.Dante Amor
Application.ScreenUpdating = False
hojas = Array("Referencia Lunes", "Referencia Martes", "Referencia Miércoles", "Referencia Jueves", "Referencia Viernes", "Referencia Semanal")
For h = LBound(hojas) To UBound(hojas)
'
Sheets(hojas(h)).Select
Range("G6:H6").Copy
Range("G6").PasteSpecial xlPasteValues
Range("C10:I33").Copy
Range("C10").PasteSpecial xlPasteValues
'
For Each obj In ActiveSheet.DrawingObjects
nombre = obj.Name
If InStr(1, UCase(nombre), "GRÁFICO") > 0 Then
ActiveSheet.ChartObjects(nombre).Activate
izq = Selection.Left
arr = Selection.Top
ActiveChart.ChartArea.Copy
Range("C10").Select
ActiveSheet.Pictures.Paste.Select
Selection.Left = izq
Selection.Top = arr
ActiveSheet.ChartObjects(nombre).Delete
Exit For
End If
Next
Next
Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Fin"
End Sub
Pusiste como ejemplo el nombre de tu gráfica "Gráfico 12", entonces revisa que en todas las gráficas tenga la palabra "Gráfico", si no es así, cambia la palabra que tengan en común en todas tus gráficas en esta línea de la macro
If InStr(1, UCase(nombre), "GRÁFICO") > 0 Then
Por ejemplo, si todas las gráficas tienen en común la palabra "Chart", entonces en la línea de la macro pones la palabra "CHART" en mayúsculas:
If InStr(1, UCase(nombre), "CHART") > 0 Then
Vuelve a probar la macro.
