VBA ¿Cómo copiar gráficas de Excel a varios archivos de Power point?
<p>Hola a todos, Soy nuevo en esta página y veo que muchos usuarios hacen honor al titulo. Espero me puedan ayudar con lo que sigue pues soy muy novato en VBA.</p><p>Necesito una macro que copie todas las gráficas de excel a varios archivos de Power Point por categorías y que los guarde.</p><p>Las gráficas no están insertadas en Hojas sino en Hojas de Gráfico (Chart Sheets). Tengo varios grupos de hojas y estas comienzan con la misma palabra. Por ejemplo tengo las pestañas (Grup1 A, Grup1 B, Grup1 C ...INIT F; y otro grupo de hojas seria. Equip1 A, Equip1 B, Equip1 C.... Equip1 F, Global1 A, Global1 B, Global1 C ....GlobalF...ect.).</p><p> </p><p>En resumen quisiera saber como podría hacer que la macro buscara todas las hojas que empiezan con Grup1 por ejemplo, copie todas estas gráficas a un archivo existente de Power Point (Grup1.PPTX) y lo guarde, despues continue con el siguiente que seria Equip1, copie sus gráficas y las guarde en Equip1.pptx despues, el siguiente grupo y asi hasta completarlos todos.</p><p>Pienso que podría ser un array, ("Grup", "Equip", Global", "Init", "IMS", ASM") y hacer un loop que busque por las primeras 4 letras para que se copien a cada archivo existente, lo guarde y despues continue con la siguiente categoria.</p><p> </p><p>Encontré esta macro que me copia todas las gráficas a un archivo existente de power Point. Solo la modifique un poco para que fuera a un archivo ya existente en lugar de uno nuevo ¿Habra forma de modificar esta macro para que haga lo que necesito? ¿Insertar un array para los titulos de las hojas y despues un loop tal vez ?</p><p> </p><p>------------------------------</p><p>Gracias y saludos :)</p><p> </p><pre class="prettyprint" style="width: 575px; height: 1536px;">Option Explicit
'Both subs require a reference to Microsoft PowerPoint xx.x Object Library.
'where xx.x is your office version (11.0 = 2003, 12.0 = 2007 and 14.0 = 2010).
'Declaring the necessary Power Point variables (are used in both subs).
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer
Sub ChartsToPowerPoint()
'Exports all the chart sheets to a new power point presentation.
'It also adds a text box with the chart title.
Dim ws As Worksheet
Dim intChNum As Integer
Dim objCh As Object
Dim File As String
'Count the embedded charts.
For Each ws In ActiveWorkbook.Worksheets
intChNum = intChNum + ws.ChartObjects.Count
Next ws
'Check if there are chart (embedded or not) in the active workbook.
If intChNum + ActiveWorkbook.Charts.Count < 1 Then
MsgBox "Sorry, there are no charts to export!", vbCritical, "Error"
Exit Sub
End If
'Open PowerPoint and create a new presentation.
'Set pptApp = New PowerPoint.Application
'########PLEASE CHANGE AS NEEDED WHERE THE FILE MUST BE SAVED#######
File = ("C:\temp\charts.pptm")
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Add
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Open(File)
'Loop through all the embedded charts in all worksheets.
For Each ws In ActiveWorkbook.Worksheets
For Each objCh In ws.ChartObjects
Call pptFormat(objCh.Chart)
Next objCh
Next ws
'Loop through all the chart sheets.
For Each objCh In ActiveWorkbook.Charts
Call pptFormat(objCh)
Next objCh
'Show the power point.
pptApp.Visible = True
'Cleanup the objects.
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
'Infrom the user that the macro finished.
MsgBox "The charts were copied successfully to the new presentation!", vbInformation, "Done"
End Sub
Private Sub pptFormat(xlCh As Chart)
'Formats the charts/pictures and the chart titles/textboxes.
Dim chTitle As String
Dim j As Integer
On Error Resume Next
'Get the chart title and copy the chart area.
chTitle = xlCh.ChartTitle.Text
xlCh.ChartArea.Copy
'Count the slides and add a new one after the last slide.
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
'-----Paste the chart and create a new textbox.
pptSlide.Shapes.PasteSpecial ppPasteJPG
If chTitle <> "" Then
pptSlide.Shapes.AddTextbox msoTextOrientationHorizontal, 12.5, 20, 694.75, 55.25
End If
'Format the picture and the textbox.
For j = 1 To pptSlide.Shapes.Count
With pptSlide.Shapes(j)
'Picture position.
If .Type = msoPicture Then
.Top = 75
.Left = 60
.Height = 420
.Width = 600
End If
'Text box position and formamt.
If .Type = msoTextBox Then
With .TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignCenter
.Text = chTitle
.Font.Name = "Tahoma (Headings)"
.Font.Size = 28
.Font.Bold = msoTrue
End With
End If
End With
Next j
End Sub
</pre>
'Both subs require a reference to Microsoft PowerPoint xx.x Object Library.
'where xx.x is your office version (11.0 = 2003, 12.0 = 2007 and 14.0 = 2010).
'Declaring the necessary Power Point variables (are used in both subs).
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer
Sub ChartsToPowerPoint()
'Exports all the chart sheets to a new power point presentation.
'It also adds a text box with the chart title.
Dim ws As Worksheet
Dim intChNum As Integer
Dim objCh As Object
Dim File As String
'Count the embedded charts.
For Each ws In ActiveWorkbook.Worksheets
intChNum = intChNum + ws.ChartObjects.Count
Next ws
'Check if there are chart (embedded or not) in the active workbook.
If intChNum + ActiveWorkbook.Charts.Count < 1 Then
MsgBox "Sorry, there are no charts to export!", vbCritical, "Error"
Exit Sub
End If
'Open PowerPoint and create a new presentation.
'Set pptApp = New PowerPoint.Application
'########PLEASE CHANGE AS NEEDED WHERE THE FILE MUST BE SAVED#######
File = ("C:\temp\charts.pptm")
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Add
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Open(File)
'Loop through all the embedded charts in all worksheets.
For Each ws In ActiveWorkbook.Worksheets
For Each objCh In ws.ChartObjects
Call pptFormat(objCh.Chart)
Next objCh
Next ws
'Loop through all the chart sheets.
For Each objCh In ActiveWorkbook.Charts
Call pptFormat(objCh)
Next objCh
'Show the power point.
pptApp.Visible = True
'Cleanup the objects.
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
'Infrom the user that the macro finished.
MsgBox "The charts were copied successfully to the new presentation!", vbInformation, "Done"
End Sub
Private Sub pptFormat(xlCh As Chart)
'Formats the charts/pictures and the chart titles/textboxes.
Dim chTitle As String
Dim j As Integer
On Error Resume Next
'Get the chart title and copy the chart area.
chTitle = xlCh.ChartTitle.Text
xlCh.ChartArea.Copy
'Count the slides and add a new one after the last slide.
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
'-----Paste the chart and create a new textbox.
pptSlide.Shapes.PasteSpecial ppPasteJPG
If chTitle <> "" Then
pptSlide.Shapes.AddTextbox msoTextOrientationHorizontal, 12.5, 20, 694.75, 55.25
End If
'Format the picture and the textbox.
For j = 1 To pptSlide.Shapes.Count
With pptSlide.Shapes(j)
'Picture position.
If .Type = msoPicture Then
.Top = 75
.Left = 60
.Height = 420
.Width = 600
End If
'Text box position and formamt.
If .Type = msoTextBox Then
With .TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignCenter
.Text = chTitle
.Font.Name = "Tahoma (Headings)"
.Font.Size = 28
.Font.Bold = msoTrue
End With
End If
End With
Next j
End Sub
</pre>
