Excel workbook to powerpoint with animation

[Keala]

I'm not so good in VBA so I hope someone with more knowledge can help me. I have a *.xls file with nine Worksheet, in each worksheet there are two charts.
What I want to do is to move the two charts from worksheet one to first page of a powerpoint file, place the two charts next to each other. Make a animation so these two appear togeather.
Then place the two charts from worksheet two as next animation on top of the first one in the powerpoint file and so on for all nine worksheets.
The result will be one page powerpoint with nine animations points, showing 18 different charts.

I have so far below code (not mine) which move the charts, but create a new page for each chart, but I would want it to make a animation of each chart instead.

Hope someone can tell me how I can change the code or maybe a link to where it is explained.

Thank you

    Option Explicit

Private Sub CommandButton1_Click()
    exportCharts2Ppt
End Sub

Sub exportCharts2Ppt()
    'Dim filename As String
    ' Create a PowerPoint application object.
    Dim objPPT As PowerPoint.Application
    Set objPPT = New PowerPoint.Application
    objPPT.Visible = True           ' Make the PPT visible.
    objPPT.Activate
    
    ' Create a PowerPoint presentation object.
    Dim objPptPre As PowerPoint.Presentation
    Set objPptPre = objPPT.Presentations.Add
    
    ' We'll show different charts in different slides in our PowerPoint presentation.
    ' Therefore, create an object for PPT slides.
    Dim objPPTSlides As PowerPoint.Slide
    
    Dim iNdx As Integer     ' Index, or position of each slide.
    iNdx = 1
    
    Dim objChart As ChartObject
    Dim objWS As Worksheet
    
    For Each objWS In ActiveWorkbook.Worksheets     ' Loop through all the worksheets.
        For Each objChart In objWS.ChartObjects     ' Loop through all the Chart Objects.
        
          
            objChart.Chart.ChartArea.Copy       ' Copy all the charts to the Clipboard.
            ' Debug.Print objChart.Chart.Name
            'ActiveChart.ChartTitle.Text = filename
            Set objPPTSlides = objPptPre.Slides.Add(iNdx, ppLayoutBlank)       ' Create a new slide with a blank layout.
            objPPTSlides.Shapes.PasteSpecial ppPasteDefault, msoTrue           ' Extract the chart from the Clipboad and paste it.
            
            iNdx = iNdx + 1         ' Increment the slide index (or position).
        Next objChart
    Next objWS
    
End Sub

 

[Worf]

The code creates this animation:

' Excel module
Sub exportCharts2Ppt()
Dim objPPT As powerpoint.Application, sld As Slide, n%, i%, sh As powerpoint.Shape
Dim pres As Presentation, cht As ChartObject, ws As Worksheet
Set objPPT = New powerpoint.Application
objPPT.Visible = True
objPPT.Activate
Set pres = objPPT.Presentations.Add
Set sld = pres.Slides.Add(1, ppLayoutBlank)
Set ws = ActiveWorkbook.Worksheets(1)
n = 1
For Each ws In ActiveWorkbook.Worksheets
    For i = 1 To 2
        Set cht = ws.ChartObjects(i)
        cht.Chart.ChartArea.Copy
        sld.Shapes.PasteSpecial ppPasteDefault, msoTrue
    Next
    Set sh = sld.Shapes(n)
    sh.Name = "Chart" & n
    sh.Width = pres.PageSetup.SlideWidth / 2
    sh.Height = pres.PageSetup.SlideHeight / 2
    sh.Top = 10
    sh.Left = 10
    Set sh = sld.Shapes(n + 1)
    sh.Name = "Chart" & n + 1
    sh.Width = pres.PageSetup.SlideWidth / 2
    sh.Height = pres.PageSetup.SlideHeight / 2
    sh.Top = 10
    sh.Left = pres.PageSetup.SlideWidth / 2
    AddEff sld, n, 22, 1, False
    AddEff sld, n + 1, 22, 2, False
    If n > 1 Then
        AddEff sld, n - 2, 22, 2, True
        AddEff sld, n - 1, 22, 2, True
    End If
    n = n + 2
Next
MsgBox sld.Shapes.Count & " charts processed.", , "done"
End Sub
Sub AddEff(sl As Slide, shn, eid, trig, ext As Boolean)
Dim eff As Effect
Set eff = sl.TimeLine.MainSequence.AddEffect(sl.Shapes(shn), eid, , trig)
eff.EffectParameters.Direction = 4
eff.Timing.Duration = 2
If ext Then eff.Exit = msoTrue
End Sub
'**********

 

[Keala]

Hi Worf,

Thank you for your great solution, this is exactly what I want the program to perform.

A further question on the same topic: Is it possible to change the code so it read several *.xls files from a folder and perform your program on different page on same *.ppt.
So what I want it to do is to let say I have folder with three *.xls-files (can be many more) open the first *.xls-file perform your solution and move charts from the *.xls-file to first page of the *.ppt-file. Close the *.xls-file open the second *.xls-file in the same folder move the charts with your program to the second page of the *.ppt-file close the *.xls file. Open the third *.xls file and so on until all *.xls-files charts in the folder is moved to the *.ppt with animation.

Thank you for your solution

 

[Worf]

New version:

Dim objppt As PowerPoint.Application, pres As Presentation, s$


Sub OpenFiles() ' run me
Dim wb As Workbook, MyFile$, Directory$
Set objppt = New PowerPoint.Application
objppt.Visible = True
objppt.Activate
Set pres = objppt.Presentations.Add
Directory = "c:\pub\2017\"
MyFile = Dir(Directory & "*.xls")
s = ""
Do While MyFile <> ""
    Set wb = Workbooks.Open(Filename:=Directory & MyFile)
    exportCharts wb
    MyFile = Dir()
    wb.Close 0
Loop
MsgBox s, , "Finished."
End Sub


Sub exportCharts(wb As Workbook)
Dim sld As Slide, n%, i%, sh As PowerPoint.shape, cht As ChartObject, ws As Worksheet
Set sld = pres.Slides.Add(1, ppLayoutBlank)
n = 1
For Each ws In wb.Worksheets
    For i = 1 To 2
        Set cht = ws.ChartObjects(i)
        cht.Chart.ChartArea.Copy
        sld.Shapes.PasteSpecial ppPasteDefault, msoTrue
    Next
    Set sh = sld.Shapes(n)
    sh.Name = "Chart" & n
    sh.Width = pres.PageSetup.SlideWidth / 2
    sh.Height = pres.PageSetup.SlideHeight / 2
    sh.Top = 10:    sh.Left = 10
    Set sh = sld.Shapes(n + 1)
    sh.Name = "Chart" & n + 1
    sh.Width = pres.PageSetup.SlideWidth / 2
    sh.Height = pres.PageSetup.SlideHeight / 2
    sh.Top = 10
    sh.Left = pres.PageSetup.SlideWidth / 2
    AddEff sld, n, 22, 1, False
    AddEff sld, n + 1, 22, 2, False
    If n > 1 Then
        AddEff sld, n - 2, 22, 2, True
        AddEff sld, n - 1, 22, 2, True
    End If
    n = n + 2
Next
s = s & sld.Shapes.Count & " charts processed for " & wb.Name & vbLf
End Sub


Sub AddEff(sl As Slide, shn, eid, trig, ext As Boolean)
Dim eff As Effect
Set eff = sl.TimeLine.MainSequence.AddEffect(sl.Shapes(shn), eid, , trig)
eff.EffectParameters.Direction = 4
eff.Timing.Duration = 2
If ext Then eff.Exit = msoTrue
End Sub

 

[Keala]

Thank you Worf for the great code. This is exactly what what to achieve.

Is there a easy way to make the Y-scale on the *.xls-file charts to the same size while moving over to the *.ppt. Let say that the first charts' Y-ax have max value of 3 and the second charts' max Y-ax is set to 30. So all charts on the *.ppt file have the same Y-size/scale.

Or should this be done before the transfer code is used, and if so is there a recommendation on how to do it?

Thank you for you answers

 

[Worf]

You can insert this line in the existing code:

Sub mscale()
Dim ws As Worksheet, i%, cht As ChartObject
For Each ws In ActiveWorkbook.Worksheets
    For i = 1 To 2
        Set cht = ws.ChartObjects(i)
[COLOR=#daa520]        cht.Chart.Axes(xlValue).MaximumScale = 30[/COLOR]
    Next
Next
End Sub

 

[Keala]

Thank you Worf, for all the great code and suggestions. This does now exactly what I want to achieve, makes it so much easier to compare the charts.