Using VBA to Copy Charts from Excel to PowerPoint

The VBA code below opens the Microsoft PowerPoint application, if not already open, and creates a new presentation. It will then copy every chart on the active Microsoft Excel worksheet and paste it into the new presentation. The program pastes one chart per slide. Each chart will be 400 pixels wide by 250 pixels tall. Each chart will be 175 pixels from the left edge of the slide and 100 pixels from the top edge of the slide. All of these parameters can be adjusted as you see fit.

Note, you will need to ensure the Microsoft PowerPoint Object Library is activated. This can be done by opening the visual basic editor, clicking the Tools drop down menu, selecting the References option, clicking the check box associated with the PowerPoint Object Library, and then clicking the OK button.

Microsoft Excel - Andon Excel - Copying charts from a spreadsheet to a powerpoint presentation.

Sub CreatePowerPoint()

Dim NPPT As PowerPoint.Application

Dim ASLD As PowerPoint.Slide

Dim ACTS As Worksheet

On Error Resume Next

Set NPPT = GetObject(, "PowerPoint.Application")

On Error GoTo 0

' Opening the PowerPoint application if it is not already open.

If NPPT Is Nothing Then

Set NPPT = New PowerPoint.Application

End If

' Creating a new presentation within the PowerPoint application.

NPPT.Presentations.Add

Set PPT1 = NPPT.ActivePresentation

' Adding a new slide to the new presentation.

PPT1.Slides.Add PPT1.Slides.Count + 1, ppLayoutBlank

Set ASLD = PPT1.Slides(PPT1.Slides.Count)

Set ACTS = ThisWorkbook.ActiveSheet

n = ACTS.ChartObjects.Count

' For the first chart to the last chart, copy the chart and paste to the active slide, then create a new slide and make it active.

For A = 1 To n

On Error Resume Next

ACTS.ChartObjects(A).Select

ActiveChart.ChartArea.Copy

ASLD.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select

Application.CutCopyMode = False

With ALSD.Shapes(A)

.Width = 400

.Height = 250

End With

With NPPT.ActiveWindow.Selection.ShapeRange

.Left = 175

.Top = 100

End With

If A = n Then

Exit For

Else

PPT1.Slides.Add PPT1.Slides.Count + 1, ppLayoutBlank

Set ASLD = PPT1.Slides(PPT1.Slides.Count)

NPPT.ActiveWindow.ViewType = ppViewSlide

End If

Next A

End Sub