I need code snippet to copy all charts and tables from Excel file for all sheets to PowerPoint file using Macro (VBA) in Excel.
Below code copies only charts. I want to copy all tables and charts and images.
Sub PushChartsToPPT()
'Set reference to 'Microsoft PowerPoint 12.0 Object Library'
'in the VBE via Tools > References...
'
Dim ppt As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
Dim pptCL As PowerPoint.CustomLayout
Dim pptShp As PowerPoint.Shape
Dim cht As Chart
Dim ws As Worksheet
Dim i As Long
'Get the PowerPoint Application object:
Set ppt = CreateObject("PowerPoint.Application")
ppt.Visible = msoTrue
Set pptPres = ppt.Presentations.Add
'Get a Custom Layout:
For Each pptCL In pptPres.SlideMaster.CustomLayouts
If pptCL.Name = "Title and Content" Then Exit For
Next pptCL
'Copy ALL charts in Chart Sheets:
For Each cht In ActiveWorkbook.Charts
Set pptSld = pptPres.Slides.AddSlide(pptPres.Slides.Count + 1, pptCL)
pptSld.Select
For Each pptShp In pptSld.Shapes.Placeholders
If pptShp.PlaceholderFormat.Type = ppPlaceholderObject Then Exit For
Next pptShp
If pptShp Is Nothing Then Stop
cht.ChartArea.Copy
ppt.Activate
pptShp.Select
ppt.Windows(1).View.Paste
Next cht
'Copy ALL charts embedded in EACH WorkSheet:
For Each ws In ActiveWorkbook.Worksheets
For i = 1 To ws.ChartObjects.Count
Set pptSld = pptPres.Slides.AddSlide(pptPres.Slides.Count + 1, pptCL)
pptSld.Select
For Each pptShp In pptSld.Shapes.Placeholders
If pptShp.PlaceholderFormat.Type = ppPlaceholderObject Then Exit For
Next pptShp
Set cht = ws.ChartObjects(i).Chart
cht.ChartArea.Copy
ppt.Activate
pptShp.Select
ppt.Windows(1).View.Paste
Next i
Next ws
End Sub
For pictures try using shapes from How to select pictures
Dim Pic As Shape
For Each Pic In ActiveSheet.Shapes
If Pic.Type = msoPicture Then
Pic.Select
'do something with image
End If
Next Pic
Related
Is there a way such that i can copy and paste multiple charts that are grouped in four as shown below from excel to my existing powerpoint slides 28 and slides 29? The name of the groups are group 16 for the left group, group 17 for the right group. I have tried to use Chrt.CopyPicture but it only copies charts separately to the slides instead of a group like the one outline on the 4 charts shown on the left side of the picture below. By the way, my only code only copies charts individually to slide 28.
Sub ExportChartsTopptSingleWorksheet()
'Declare PowerPoint Variables
Dim PPTApp As Object
Dim PPTPres As Object
Dim PPTShape As Object
Dim mySlide, myslide2 As Object
'Declare Excel Variables
Dim Chrt As ChartObject
If PPTApp Is Nothing Then _
Set PPTApp = CreateObject(class:="PowerPoint.Application")
On Error GoTo 0
PPTApp.Visible = True
'Create new presentation in the PowerPoint application.
Set PPTPres = PPTApp.Presentations.Open(Filename:="\\fab2crp-nas1\home22\kkang2\Profile\Desktop\myassignment3\mypresentationsample.pptx")
Set mySlide = PPTPres.Slides.Add(28, 1)
'Loop through all the CHARTOBJECTS in the ACTIVESHEET.
For Each Chrt In ActiveSheet.ChartObjects
'Copy the Chart
Chrt.CopyPicture '<------ method copy fail error here
'paste all the chart on to exisitng ppt slide 28
mySlide.Shapes.Paste
Next Chrt
End Sub
Currently, charts are copied individually to ppt slides
Expected
This worked for me.
Sub ExportChartsTopptSingleWorksheet()
Const PER_ROW As Long = 2 'charts per row in PPT
Const T_START As Long = 40 'start chart top
Const L_START As Long = 40 'start chart left
Dim PPTApp As Object
Dim PPTPres As Object
Dim PPTShape As Object
Dim mySlide, myslide2 As Object, i As Long
Dim Chrt As ChartObject, T As Long, L As Long
If PPTApp Is Nothing Then _
Set PPTApp = CreateObject(class:="PowerPoint.Application")
PPTApp.Visible = True
Set PPTPres = PPTApp.Presentations.Add()
Set mySlide = PPTPres.Slides.Add(1, 1)
i = 0
For Each Chrt In ActiveSheet.ChartObjects
Chrt.Chart.CopyPicture
i = i + 1
'work out the top/left values
T = T_START + (Application.Floor((i - 1) / PER_ROW, 1)) * Chrt.Height
L = L_START + ((i - 1) Mod PER_ROW) * Chrt.Width
With mySlide.Shapes
.Paste
.Item(.Count).Top = T
.Item(.Count).Left = L
End With
Next Chrt
End Sub
I have 2 charts on each sheets in a workbook and I would like to copy 2 to each slide's placeholders. The code now keeps creating a new PowerPoint instead of using the template I have opened. I have the following code.
Sub CopyPasteCharts()
MsgBox "Select the file you have generated.", vbInformation + vbOKOnly
Dim fNameAndPath As Variant, wb As Workbook
fNameAndPath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Select File To Be Opened")
If fNameAndPath = False Then Exit Sub
Set wb = Workbooks.Open(fNameAndPath)
wb.Activate
Dim ppt As PowerPoint.Application
Dim ppTPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
Dim pptCL As PowerPoint.CustomLayout
Dim pptShp As PowerPoint.Shape
Dim chtt As Chart
Dim ws As Worksheet
Dim i As Long
'Optimise execution of code
Application.ScreenUpdating = False
'Get the PowerPoint Application object:
Set ppt = CreateObject("PowerPoint.Application")
ppt.Visible = msoTrue
'Set ppTPres = ppt.Presentations.Add
'Get a Custom Layout:
For Each pptCL In ppTPres.SlideMaster.CustomLayouts
If pptCL.Name = "Title and Content" Then Exit For
Next pptCL
'Copy ALL charts embedded in EACH WorkSheet:
For Each ws In ActiveWorkbook.Worksheets
Set pptSld = ppTPres.Slides.AddSlide(ppTPres.Slides.Count + 1, pptCL)
pptSld.Select
For i = 1 To ws.ChartObjects.Count
For Each pptShp In pptSld.Shapes.Placeholders
If pptShp.PlaceholderFormat.Type = ppPlaceholderObject Then Exit For
Next pptShp
Set chtt = ws.ChartObjects(i).Chart
chtt.ChartArea.Copy
ppt.Activate
pptShp.Select
ppt.Windows(1).View.Paste
Next i
Next ws
'Optimise execution of code
Set chtt = Nothing
Set pptSld = Nothing
Application.ScreenUpdating = True
'Clear clipboard
Application.CutCopyMode = False
End Sub
this is how my placeholders look like
[EDIT]
I have changed the code but there. A subscript out of range happens at ActiveWorkbook.Worksheets("Chart 1").ChartObjects(1).Activate.ChartArea.Copy
New code:
'To get the file
fNameAndPath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Select File To Be Opened")
If fNameAndPath = False Then Exit Sub
Set wb = Workbooks.Open(fNameAndPath)
wb.Activate
Dim obPptApp As PowerPoint.Application
Dim OpenPptDialogBox As Object
Dim MyChart As Chart
Dim MyShape As Object
Set obPptApp = CreateObject("PowerPoint.Application")
Set OpenPptDialogBox = obPptApp.FileDialog(msoFileDialogOpen)
'Open the target PPT using dialog box
If OpenPptDialogBox.Show = -1 Then
obPptApp.Presentations.Open (OpenPptDialogBox.SelectedItems(1))
End If
'Copy the chart from excel macro file
ActiveWorkbook.Worksheets("Chart 1").ChartObjects(1).Activate.ChartArea.Copy
'Paste the chart in slide 1 of PPT
Set MyShape = obPptApp.ActiveWindow.Presentation.Slides(1).Shapes.Paste
My code now is pasting 1 chart onto 1 slide. How do I make it paste all of the charts on Sheet1 (2 charts in Sheet1) to Slide1 and all of the charts (2 charts in Sheet2) on Sheet2 to Slide2, and so on... I tried increasing the count but the code fails.
Dim ppt As PowerPoint.Application
Dim ppTPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
Dim pptCL As PowerPoint.CustomLayout
Dim pptShp As PowerPoint.Shape
Dim chtt As Chart
Dim ws As Worksheet
Dim i As Long
'Optimise execution of code
Application.ScreenUpdating = False
'Get the PowerPoint Application object:
Set ppt = CreateObject("PowerPoint.Application")
ppt.Visible = msoTrue
Set ppTPres = ppt.Presentations.Add
'Get a Custom Layout:
For Each pptCL In ppTPres.SlideMaster.CustomLayouts
If pptCL.Name = "Title and Content" Then Exit For
Next pptCL
For Each ws In ActiveWorkbook.Worksheets
For i = 1 To ws.ChartObjects.Count
Set pptSld = ppTPres.Slides.AddSlide(ppTPres.Slides.Count + 1, pptCL)
pptSld.Select
For Each pptShp In pptSld.Shapes.Placeholders
If pptShp.PlaceholderFormat.Type = ppPlaceholderObject Then Exit For
Next pptShp
Set chtt = ws.ChartObjects(i).Chart
chtt.ChartArea.Copy
ppt.Activate
pptShp.Select
ppt.Windows(1).View.Paste
Next i
Next ws
'Optimise execution of code
Set chtt = Nothing
Set pptSld = Nothing
Application.ScreenUpdating = True
'Clear clipboard
Application.CutCopyMode = False
I have a code in Excel VBA that will export both my charts and data tables to PowerPoint, but I can't seem to get them both on the same slides (so chart above data table in PowerPoint). Please help.
Sub ExportMultipleChartsToPowerPoint_FullWorkbook3()
'Declare PowerPoint Object Variables
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim PPTShapeRng As PowerPoint.ShapeRange
Dim ShpCnt As Integer
'Declare Excel Object Variables
Dim Chrt As ChartObject
Dim Wrksht As Worksheet
Dim SldIndex As Integer
Dim ExcRng As Range
Dim RngArray As Variant
'Create a new instance of PowerPoint
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
'Create a new Presentation within the Application
Set PPTPres = PPTApp.Presentations.Add
'Create an Index Handler for slide creation
SldIndex = 1
'For Errors
On Error Resume Next
'Look through all of the Worksheets in the ACTIVE WORKBOOK
For Each Wrksht In Worksheets
'Loop through all the Chart Objects on the ACTIVESHEET
For Each Chrt In Wrksht.ChartObjects
'Copy the chart
Chrt.Copy
'Tell Macro to wait for ONE SECOND
Application.Wait Now + #12:00:01 AM#
'Create a new slide, set the layout to blank, and paste the chart
Set PPTSlide = PPTPres.Slides.Add(SldIndex, ppLayoutTitleOnly)
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteJPG
'Add Text to Slide Title and format
PPTSlide.Shapes(1).TextFrame.TextRange = "X008 - CARS all bookings consultant YR details"
'Count the number of shapes on my slide
ShpCnt = PPTSlide.Shapes.Count
'Set a reference to the shape I want to manipulate
Set PPTShapeRng = PPTSlide.Shapes.Range(Array(ShpCnt))
'Set Dimension of my shape range
With PPTShapeRng
.Height = 240
.Width = 660
.Top = 135
.Align msoAlignCenters, True
End With
'Increment our slide index
SldIndex = SldIndex + 1
Next Chrt
Next Wrksht
'Create an array that has the references to the ranges I want to export
RngArray = Array(Worksheets("Global Results").Range("A30:H37"), Worksheets("G-FPO-GC").Range("A30:H37"), Worksheets("G-FPO-GCA").Range("A30:H37"), Worksheets("G-FPO-GCE").Range("A30:H37"), Worksheets("G-FPO-GCG").Range("A30:H37"), Worksheets("G-FPO-GCN").Range("A30:H37"), Worksheets("G-FPO-GCO").Range("A30:H37"))
'Loop through this array, copy the range, and create a new slide, and then paste the range in the slide
For x = LBound(RngArray) To UBound(RngArray)
'Set a reference to the range we want to export
Set ExcRng = RngArray(x)
'Copy the range
ExcRng.Copy
'Create a new slide in the presentation
Set PPTSlide = PPTPres.Slides.Add(x + 1, ppLayoutTitleOnly)
'Paste the range in the slide
PPTApp.ActiveWindow.ViewType = ppViewNormal
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'Count the number of shapes on my slide
ShpCnt = PPTSlide.Shapes.Count
'Set a reference to the shape I want to manipulate
Set PPTShapeRng = PPTSlide.Shapes.Range(Array(ShpCnt))
'Set the dimensions of my shaperange
With PPTShapeRng
.Align msoAlignCenters, True
.Left = 80
.Top = 430
.Height = 100
End With
Next x
End Sub
Every now and then, there will be another error message that says there's something wrong with my Chrt.Copy and I have no idea why
I have a standard code that prints all charts in your active sheet to a new powerpoint application:
Sub CreatePowerPoint()
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each cht In ActiveSheet.ChartObjects
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
'Copy the chart and paste it into the PowerPoint as a Metafile Picture
cht.Select
ActiveChart.ChartArea.Copy
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'Set the title of the slide the same as the title of the chart
activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
'Adjust the positioning of the Chart on Powerpoint Slide
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125
activeSlide.Shapes(2).Width = 200
activeSlide.Shapes(2).Left = 505
Next
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
What I need to do is change the instead of activesheet to whole workbook, so copy over all charts in workbook. I tried introducing what I use to read through the workbook and delete all sheets :
Sub ClearCharts()
Dim wsItem As Worksheet
Dim chtObj As ChartObject
For Each wsItem In ThisWorkbook.Worksheets
For Each chtObj In wsItem.ChartObjects
chtObj.Delete
Next
Next
End Sub
but it runs and doesnt copy over the charts when I try and edit the activesheet line. Any ideas would be appreciated for me to progress.
Thankyou
I'm trying to do a similar thing at the moment, looking at the code above you have 3 For Each loops but you should only have 2 I believe. One to Loop over the sheets and a second to loop over each chart in the sheet.
You have to activate the sheet before you export the chart. I have faced this problem in the past when exporting the charts.
Try this
Dim wsItem As Worksheet
Dim chtObj As ChartObject
For Each wsItem In ThisWorkbook.Worksheets
For Each chtObj In wsItem.ChartObjects
wsItem.Activate
'~~> Code here to copy it to the poerpoint
'~~> Same for deleting it
DoEvents
Next
Next
` Sub SelectedSheetsPowerPoint()
Dim wsItem As Worksheet
Dim chtObj As ChartObject
For Each wsItem In ThisWorkbook.Worksheets
For Each chtObj In wsItem.ChartObjects
wsItem.Activate
'~~> Code here to copy it to the poerpoint
'~~> Same for deleting it
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each cht In ActiveSheet.ChartObjects
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.count)
'Copy the chart and paste it into the PowerPoint as a Metafile Picture
cht.Select
ActiveChart.ChartArea.Copy
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'Set the title of the slide the same as the title of the chart
activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
'Adjust the positioning of the Chart on Powerpoint Slide
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 75
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 120
activeSlide.Shapes(2).Width = 200
activeSlide.Shapes(2).Left = 505
'loop through each chart in !!activesheet!! and move each into a new slide!
Next
'start pp, can add preset headings for power point here
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
DoEvents
Next
Next
End Sub
`
it runs through and puts out all graphs but it doesn't stop, it will just keep copying and looping through all the sheets until I closed it out after it copied about 15 times.