CODEWITHSUNDEEP
excelvbachartspowerpoint
user12447159
user12447159

Reputation:

rearrange charts in powerpoint using VBA

I created some graphs in Excel using VBA. Now I would like to send it to my PP template and arrange 4 charts in the same slide, then skip to the next slide and add another 4 charts. All charts need to be resized and rearranged. I managed to export the first 4 charts, but when I want to arrange them and fit the size then I run in to problems. I have limited VBA experience and no experience using VBA together with MS PP.

My code so far:

    Dim PPT As Object
    Dim chr
    Set PPT = CreateObject("Powerpoint.Application")
    PPT.Visible = True
    PPT.Presentations.Open Filename:="C:\VBA Projects\XXX\XXX.ppt"
'    Set PPT = Nothing
    PPT.ActiveWindow.View.GotoSlide 4
    For Each chr In Sheets("Output").ChartObjects
        chr.Select
        ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
        PPT.ActiveWindow.View.Paste
    Next chr

End Sub

How can I choose between the charts and manipulate them individually?

Thank you

Upvotes: 0

Views: 416

Answers (1)

Domenic
Domenic

Reputation: 8114

After pasting the chart into the slide, you can use the following code to refer to and set the properties for the currently pasted chart.

    With PPT.ActiveWindow.View.Slide
        With .Shapes(.Shapes.Count)
            'set properties for shape
            '
            '
        End With
    End With

By the way, I would suggest that you replace...

ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture

with

chr.Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture

Otherwise, you'll get an error if the worksheet containing the chart is not the active sheet.

EDIT

The following code will loop through each ChartObject object in sheet "Output", and then copy each one to the PowerPoint presentation so that each slide contains 4 charts, starting with the 4th slide. Change the property settings as desired.

Const START_LEFT_POS As Long = 25
Const START_TOP_POS As Long = 60
Const GAP As Long = 30 'gap between charts

Dim LeftPos As Long
LeftPos = START_LEFT_POS

Dim TopPos As Long
TopPos = START_TOP_POS

Dim NextSlideIndex As Long
NextSlideIndex = 4

PPT.ActiveWindow.View.GotoSlide NextSlideIndex

With Sheets("Output")
    Dim ChrtIndex As Long
    For ChrtIndex = 1 To .ChartObjects.Count
        .ChartObjects(ChrtIndex).Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
        PPT.ActiveWindow.View.Paste
        With PPT.ActiveWindow.View.slide
            With .Shapes(.Shapes.Count)
                .Left = LeftPos
                .Top = TopPos
                .Width = 200
                .Height = 200
                If ChrtIndex Mod 2 = 1 Then
                    LeftPos = LeftPos + .Width + GAP
                Else
                    LeftPos = START_LEFT_POS
                    TopPos = TopPos + .Height + GAP
                End If
            End With
        End With
        If ChrtIndex Mod 4 = 0 Then
            LeftPos = START_LEFT_POS
            TopPos = START_TOP_POS
            NextSlideIndex = NextSlideIndex + 1
            PPT.ActiveWindow.View.GotoSlide NextSlideIndex
        End If
    Next ChrtIndex
End With

Upvotes: 0

Related Questions