Macro to automatically create powerpoint that grabs charts from excel

[MyCuteHeart]

Hi Guyz,

Been doing a macro that grabs all charts from excel workbook and automatically create powerpoint. I am creating a chartlist first that would specify what slide number and slide sequence the chart would go. However, it doesn't do the way I want in the powerpoint. Please help.

Function createCharts(myWorkSheet, myFname)
Dim objApp As PowerPoint.Application
Dim ppRes As PowerPoint.Presentation
Dim ppSld As PowerPoint.Slide
Dim slideIndex, slideNum, slideSeq As Integer
Dim charwidth, charHeight, charLeft, charTop As Integer

Set objApp = New PowerPoint.Application
objApp.Visible = True
Application.ScreenUpdating = True
objApp.WindowState = ppWindowMinimized
objApp.Presentations.Open Filename:=myFname, ReadOnly:=msoTrue

Worksheets(myWorkSheet).Select
Range("A2").Select
Application.ScreenUpdating = False
Application.StatusBar = "Creating charts, please wait..."

Set ppRes = objApp.ActivePresentation
myCount = ppRes.Slides.Count
For i = 1 To myCount
ppRes.Slides(1).Delete
Next

slideIndex = 0
chtWorkSheet = Trim(ActiveCell.Value)
Do While Not chtWorkSheet = ""
sheetName = ActiveCell.Value
chartIndex = ActiveCell.Offset(0, 1).Value
ChartTitle = ActiveCell.Offset(0, 2).Value
slideNum = ActiveCell.Offset(0, 3).Value
slideSeq = ActiveCell.Offset(0, 4).Value

If slideNum = 0 Or slideSeq = 0 Then
MsgBox "Slide number or sequence not filled in. Cannot proceed.", vbCritical, "CreateCharts"
objApp.Quit
Set ppRes = Nothing
Set objApp = Nothing
createCharts = False
Exit Function
End If

If Not slideNum = slideIndex Then

slideIndex = slideNum

ppRes.Slides.Add Index:=slideIndex, Layout:=ppLayoutTitleOnly
objApp.ActiveWindow.View.GotoSlide Index:=slideNum
Set ppSld = ppRes.Slides(objApp.ActiveWindow.Selection.SlideRange.slideIndex)
End If

Select Case slideSeq
Case 1
charHeight = chartHeight
charwidth = chartWidth
charTop = chartTop
charLeft = chartLeft
Case 2
charHeight = chartHeight
charwidth = chartWidth
charTop = chartTop
charLeft = chartLeft + chartWidth + 10
Case 3
charHeight = chartHeight
charwidth = chartWidth
charTop = chartTop + chartHeight + 10
charLeft = chartLeft
Case 4
charHeight = chartHeight
charwidth = chartWidth
charTop = chartTop + chartHeight + 10
charLeft = chartLeft + chartWidth + 10
End Select

Worksheets(chtWorkSheet).ChartObjects(ActiveCell.Offset(0, 1).Value).Activate

ActiveChart.ChartArea.Copy

ppSld.Select
ppSld.Shapes.PasteSpecial (ppPastePNG)
ppSld.Select
myCount = ppSld.Shapes.Count

With ppRes.Slides(slideIndex).Shapes(myCount)
.Top = charTop
.Left = charLeft
.Width = charwidth
.Height = charHeight
End With

Worksheets(myWorkSheet).Select
ActiveCell.Offset(1, 0).Select
chtWorkSheet = Trim(ActiveCell.Value)
Loop

objApp.WindowState = ppWindowMaximized
createCharts = True
End Function

 

[Sal Paradise]

Since you are deleting all the slides first, and then trying to add slides afterwards (out of order), you may want to try one of the following:

1) Count how many charts you will have first, and create that many new slides in powerpoint (then you can just go to whatever slide and paste)

2) Sort your chart list in Excel by slide order (that way you can just add each new slide at the end of the presentation)