CODEWITHSUNDEEP
vba
md arshad ali
md arshad ali

Reputation: 15

Need to transfer all charts from Excel in PPT

I have a script which transfer all my charts to PPT perfectly but the issue is all chart paste in different slides. I have small charts that mean in a single slide can be store 4 charts. Is there any kind of script which arrange the charts as well in PPT slide and paste at least 4 charts in single slide of PPT. Currently I'm using the below code

Sub Chart_TRF()
Dim PApp As PowerPoint.Application
Dim PPres As PowerPoint.Presentation
Dim PSlide As PowerPoint.Slide
Dim slide_index As Integer

Dim Chrt As ChartObject

Set PApp = New PowerPoint.Application

PApp.Visible = True

Set PPres = PApp.Presentations.Add
slide_index = 1
For Each Chrt In ActiveSheet.ChartObjects
Chrt.Copy
Set PSlide = PPres.Slides.Add(slide_index, ppLayoutBlank)
PSlide.Shapes.Paste
slide_index = slide_index + 1
Next Chrt

MsgBox ("PPT is created for all Charts")

End Sub

Please let me know if you have any query on this.

Thanks

Upvotes: 0

Views: 41

Answers (1)

Domenic
Domenic

Reputation: 8104

I have amended your code so that each slide will contain 4 charts. You can change the starting left and top positions, along with the gap between charts, as desired.

Sub Chart_TRF()

    Const START_LEFT_POS As Long = 20 'change the starting left position as desired
    Const START_TOP_POS As Long = 20 'change the starting top position as desired
    Const GAP As Long = 30 'change the gap between charts as desired

    Dim PApp As PowerPoint.Application
    Dim PPres As PowerPoint.Presentation
    Dim PSlide As PowerPoint.Slide
    Dim PShape As PowerPoint.Shape
    Dim slide_index As Integer
    Dim chart_index As Integer
    Dim left_pos As Integer
    Dim top_pos As Integer
    
    Dim Chrt As ChartObject
    
    Set PApp = New PowerPoint.Application
    
    PApp.Visible = True
    
    Set PPres = PApp.Presentations.Add
    
    slide_index = 0
    chart_index = 0
    left_pos = START_LEFT_POS
    top_pos = START_TOP_POS
    For Each Chrt In ActiveSheet.ChartObjects
        chart_index = chart_index + 1
        If chart_index Mod 4 = 1 Then
            slide_index = slide_index + 1
            Set PSlide = PPres.Slides.Add(slide_index, ppLayoutBlank)
            top_pos = START_TOP_POS
        End If
        Chrt.Copy
        Set PShape = PSlide.Shapes.Paste(1)
        If chart_index Mod 2 = 1 Then
            With PShape
                .Left = left_pos
                .Top = top_pos
                left_pos = left_pos + .Width + GAP
            End With
        Else
            With PShape
                .Left = left_pos
                .Top = top_pos
                left_pos = START_LEFT_POS
                top_pos = top_pos + .Height + GAP
            End With
        End If
    Next Chrt
    
    MsgBox ("PPT is created for all Charts")

End Sub

EDIT

Here's the code that will copy the charts from all worksheets in the active workbook.

Sub Chart_TRF()

    Const START_LEFT_POS As Long = 20 'change the starting left position as desired
    Const START_TOP_POS As Long = 20 'change the starting top position as desired
    Const GAP As Long = 30 'change the gap between charts as desired

    Dim PApp As PowerPoint.Application
    Dim PPres As PowerPoint.Presentation
    Dim PSlide As PowerPoint.Slide
    Dim PShape As PowerPoint.Shape
    Dim slide_index As Integer
    Dim chart_index As Integer
    Dim left_pos As Integer
    Dim top_pos As Integer
    
    Dim Chrt As ChartObject
    Dim ws As Worksheet
    
    Set PApp = New PowerPoint.Application
    
    PApp.Visible = True
    
    Set PPres = PApp.Presentations.Add
    
    slide_index = 0
    chart_index = 0
    left_pos = START_LEFT_POS
    top_pos = START_TOP_POS
    For Each ws In ActiveWorkbook.Worksheets
        For Each Chrt In ws.ChartObjects
            chart_index = chart_index + 1
            If chart_index Mod 4 = 1 Then
                slide_index = slide_index + 1
                Set PSlide = PPres.Slides.Add(slide_index, ppLayoutBlank)
                top_pos = START_TOP_POS
            End If
            Chrt.Copy
            Set PShape = PSlide.Shapes.Paste(1)
            If chart_index Mod 2 = 1 Then
                With PShape
                    .Left = left_pos
                    .Top = top_pos
                    left_pos = left_pos + .Width + GAP
                End With
            Else
                With PShape
                    .Left = left_pos
                    .Top = top_pos
                    left_pos = START_LEFT_POS
                    top_pos = top_pos + .Height + GAP
                End With
            End If
        Next Chrt
    Next ws
    
    MsgBox ("PPT is created for all Charts")

End Sub

Upvotes: 1

Related Questions