Need to transfer all charts from Excel in PPT - vba

Question

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

Answer 1

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