This is my first time asking a question here, as you guys and gals are so good that I've never had to until now!
I have the following VBA code, which successfully pulls charts from a spreadsheet, and pastes them onto two newly created PPT slides. The only problem however, is that this code ONLY aligns the chart on the second slide, and doesn't affect the chart on the first slide.
I can't for the life of me figure out what's going on her, and would greatly appreciate any input!
Option Explicit
Sub MakeSlides()
Dim myData As Excel.Range
Dim sheet2 As Excel.Worksheet
Dim objPPT As Object
Set sheet2 = ActiveWorkbook.Sheets("Sheet2")
Set myData = sheet2.Range("A2:B43")
Set objPPT = CreateObject("Powerpoint.application")
myData.Copy
Dim pptApp As New PowerPoint.Application
pptApp.Visible = True
Dim pres As PowerPoint.Presentation
Set pres = pptApp.Presentations.Add
Dim firstslide As PowerPoint.Slide
Set firstslide = pres.Slides.Add(1, PowerPoint.PpSlideLayout.ppLayoutBlank)
Dim myChart As Excel.ChartObject
Set myChart = Sheet1.ChartObjects(1)
myChart.Copy
firstslide.Shapes.Paste.Select
' Align pasted chart
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
Set sheet2 = ActiveWorkbook.Sheets("Sheet2")
Set myData = sheet2.Range("A45:B69")
myData.Copy
pptApp.Visible = True
Dim secondslide As PowerPoint.Slide
Set secondslide = pres.Slides.Add(1, PowerPoint.PpSlideLayout.ppLayoutBlank)
Set myChart = Sheet1.ChartObjects(2)
myChart.Copy
secondslide.Shapes.Paste
' Align pasted chart
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
End Sub
Maybe like this; aligning the chart on the first slide right after you paste it in:
Option Explicit
Sub MakeSlides()
[...]
myChart.Copy
firstslide.Shapes.Paste.Select
' Align pasted chart
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
Set sheet2 = ActiveWorkbook.Sheets("Sheet2")
Set myData = sheet2.Range("A45:B69")
myData.Copy
pptApp.Visible = True
Dim secondslide As PowerPoint.Slide
Set secondslide = pres.Slides.Add(1, PowerPoint.PpSlideLayout.ppLayoutBlank)
Set myChart = Sheet1.ChartObjects(2)
myChart.Copy
secondslide.Shapes.Paste
' Align pasted chart
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
End Sub
Try this instead.
A few points:
You don't need a new variable for each chart/slide etc. One, reused as needed, is plenty.
Never use SELECT unless there's no way around it (in Excel or PPT). It makes the code more fragile and forces you to make the app visible (not really necessary most of the time). It also slows your code down by an order of magnitude since PPT has to redraw everything.
Sub MakeSlides()
Dim myData As Excel.Range
Dim sheet2 As Excel.Worksheet
Dim objPPT As Object
Set sheet2 = ActiveWorkbook.Sheets("Sheet2")
Set myData = sheet2.Range("A2:B43")
Set objPPT = CreateObject("Powerpoint.application")
myData.Copy
Dim pptApp As New PowerPoint.Application
pptApp.Visible = True
Dim pres As PowerPoint.Presentation
Set pres = pptApp.Presentations.Add
Dim oSlide As PowerPoint.Slide
Dim oChtShape as PowerPoint.Shape
Set oSlide = pres.Slides.Add(1, PowerPoint.PpSlideLayout.ppLayoutBlank)
Dim myChart As Excel.ChartObject
Set myChart = Sheet1.ChartObjects(1)
myChart.Copy
Set oChtShape = oSlide.Shapes.Paste(1)
' Align pasted chart
oChtShape.Align msoAlignCenters, True
oChtShape.Align msoAlignMiddles, True
' Not sure what this is supposed to do:
Set sheet2 = ActiveWorkbook.Sheets("Sheet2")
Set myData = sheet2.Range("A45:B69")
myData.Copy
' it's already visible; don't need this
'pptApp.Visible = True
' don't need a new object variable for each slide;
' reuse the existing variable instead
Set oSlide = pres.Slides.Add(1, PowerPoint.PpSlideLayout.ppLayoutBlank)
Set myChart = Sheet1.ChartObjects(2)
myChart.Copy
'secondslide.Shapes.Paste
Set oChtShape = oSlide.Shapes.Paste(1)
' Align pasted chart
oChtShape.Align msoAlignCenters, True
oChtShape.Align msoAlignMiddles, True
End Sub
Related
I am fairly new at this but am beating my head on this. I have a basic functioning code where it opens up the PP and inputs the data from my excel sheets. But it auto centers each sheet's array and the text looks very small. I want to be able to basically make the text larger on different scales, and reposition a couple arrays on each sheet as I see fit. I know the "populate our arrays" is kind of truncated, so I would assume I would need to break that apart to apply the custom dimensions to each sheet. Thank you so much in advance.
Sub ExportMultipleRangeToPowerPoint_Method1()
'Declare PowerPoint Variables
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
'Opens a new PowerPoint presentation based on template and pastes data into Slide 2 of Powerpoint from Excel
Dim PPapp As PowerPoint.Application, PPpres As PowerPoint.Presentation, PPslide As PowerPoint.Slide, PPShape As Object
Dim XLws As Worksheet
'Declare Excel Variables
Dim ExcRng As Range
Dim RngArray As Variant
Dim ShtArray As Variant
'Populate our arrays
RngArray = Array("A1:E16", "C2:E6", "B2:D6")
ShtArray = Array("Summary", "Sheet2", "Sheet3")
'Create a new instance of PowerPoint
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
'Create a new Presentation
Set PPTPres = PPTApp.Presentations.Add
'Loop through the range array, create a slide for each range, and copy that range on to the slide.
For x = LBound(RngArray) To UBound(RngArray)
'Set a reference to the range
Set ExcRng = Worksheets(ShtArray(x)).Range(RngArray(x))
'Copy the range
ExcRng.Copy
'Create a new Slide
Set PPTSlide = PPTPres.Slides.Add(x + 1, ppLayoutBlank)
'Paste the range in the slide
PPTSlide.Shapes.Paste
Next x
End Sub
Try
' width, height, left, top
ImgArray = Array("300,300,100,100", _
"200,200,200,200", _
"150,150,150,150")
'Create a new instance of PowerPoint
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
'Create a new Presentation
Set PPTPres = PPTApp.Presentations.Add
'Loop through the range array, create a slide for each range, and copy that range on to the slide.
Dim x
For x = LBound(RngArray) To UBound(RngArray)
'Set a reference to the range
Set ExcRng = Worksheets(ShtArray(x)).Range(RngArray(x))
'Copy the range
ExcRng.Copy
'Create a new Slide
Set PPTSlide = PPTPres.Slides.Add(x + 1, ppLayoutBlank)
'Paste the range in the slide
ar = Split(ImgArray(x), ",")
With PPTSlide.Shapes.PasteSpecial(ppPasteOLEObject)
.Width = ar(0)
.Height = ar(1)
.Left = ar(2)
.Top = ar(3)
End With
Next x
How do I copy an Excel chart into a PowerPoint slide?
Here is the code I have so far.
'There is a bunch of other stuff defined.
' Just showing what I think are relevant definitions
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim shp As PowerPoint.Shape
Dim sld As PowerPoint.Slide
Dim xlChrt As Excel.ChartObject
Set pptApp = CreateObject("PowerPoint.Application")
'This opens up my PowerPoint file
Set ppPres = pptApp.Presentations.Open(myPath & pptFile)
'This activates the worksheet where my chart is
Workbooks(wb2).Sheets("Sheet 1").Activate
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.ChartArea.Copy
'I think that my copying works because after I run the module,
' I have the chart in my clipboard.
'This takes me to slide 2 of my PowerPoint.
Set sld = pptPres.Slides(2)
sld.Shapes.Paste 'But nothing pastes to the slide
I am copying the chart because it is in my clipboard after the module runs.
I successfully reference the PowerPoint slide as later in the code, I edit text boxes on slide 2.
I believe your code should work if you correct the set pptPres statement. This example is a simplified example based on your code:
Option Explicit
Public Sub CopyChart()
Const myPath = "c:\temp\"
Const pptFile = "test.pptx"
Dim pptApp As New PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
' Open the PowerPoint and reference the slide
Set pptPres = pptApp.Presentations.Open(myPath & pptFile)
Set sld = pptPres.Slides(2)
' Copy the Chart
ActiveWorkbook.Sheets("Sheet 1").ChartObjects("Chart 1").Copy
' Paste it into the PowerPoint
sld.Shapes.Paste
End Sub
And the result ... you can see the chart pasted onto slide 2:
UPDATED ANSWER
Chartsheets aren't as functional as embedded charts: https://learn.microsoft.com/en-us/office/vba/api/excel.chart(object)
Here is one option which is small variation of the above which works for chartsheets:
Option Explicit
Public Sub CopyChartSheet()
Const myPath = "c:\temp\"
Const pptFile = "test.pptx"
Dim pptApp As New PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim myChart As Excel.Chart
Dim sld As PowerPoint.Slide
' Open the PowerPoint and reference the slide
Set pptPres = pptApp.Presentations.Open(myPath & pptFile)
Set sld = pptPres.Slides(2)
' Copy the Chart
Set myChart = ActiveWorkbook.Charts("Chart 1")
myChart.CopyPicture
' Paste it into the PowerPoint
sld.Shapes.Paste
End Sub
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 cant figure out how to incorporate my template into my actual code in VBA so that my sheets will build in the desired template and slides.
I have built the slides in a new blank powerpoint slides but cant figure out how to do it with template yet.
Sub LCTAKT_Macro()
'Declare variables
Dim PP As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide1 As PowerPoint.Slide
Dim PPSlide2 As PowerPoint.Slide
Dim PPSlide3 As PowerPoint.Slide
Dim PPSlide4 As PowerPoint.Slide
Dim PPSlide5 As PowerPoint.Slide
Dim PPSlide6 As PowerPoint.Slide
Dim PPSlide7 As PowerPoint.Slide
Dim SlideTitle As String
Dim objPPT As Object
'Open PowerPoint and create new presentation
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Set PP = New PowerPoint.Application
Set PPPres = PP.Presentations.Add
PP.Visible = True
objPPT.Presentations.Open ""
'-------------------------------------------------Station 42--------- ------------------------------------------------
'Add new slide as slide 2 and set focus to it
Set PPSlide1 = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPSlide1.Select
'Copy the range as a picture
Sheets("").Range("A1:W59").CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
'Paste the picture and adjust its position
PPSlide1.Shapes.Paste.Select
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
'Add the title to the slide
SlideTitle = ""
PPSlide1.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
'Position pasted chart
PP.ActiveWindow.Selection.ShapeRange.Left = 200
PP.ActiveWindow.Selection.ShapeRange.Top = 130
PP.ActiveWindow.Selection.ShapeRange.Height = 523
PP.ActiveWindow.Selection.ShapeRange.Width = 554
I expect the template to be incorporated in the slides while still building the necessary data snippets to it.
Assuming Office 2013 or better, try this:
TemplateName$ = "C:\Users\YourActualUserName\Documents\Custom Office Templates\YourActualTemplateName.potx"
Set PPPres = PP.Presentations.Open(TemplateName$, False, True, True)
I'm an amateur coder. I'm trying to put something together to transfer all charts in an excel file to different slides on a powerpoint. I've tested several modules online (some from here as well). I've found this one below to be the most comprehensive for me so far. I have 3 graphs on a worksheet and for some reason I can't figure out, the code only copies one graph (first created), makes new slide and sticks it on that second slide. No idea what's going on, any help would be appreciated:
Sub ChartsAndTitlesToPresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PresentationFileName As Variant
Dim SlideCount As Long
Dim iCht As Integer
Dim sTitle As String
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
For iCht = 1 To ActiveSheet.ChartObjects.Count
With ActiveSheet.ChartObjects(iCht).Chart
' get chart title
If .HasTitle Then
sTitle = .ChartTitle.Text
Else
sTitle = ""
End If
' remove title (or it will be redundant)
.HasTitle = False
' copy chart as a picture
.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' restore title
If Len(sTitle) > 0 Then
.HasTitle = True
.ChartTitle.Text = sTitle
End If
End With
' Add a new slide and paste in the chart
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
With PPSlide
' paste and select the chart picture
.Shapes.Paste.Select
' align the chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
.Shapes.Placeholders(1).TextFrame.TextRange.Text = sTitle
End With
Next
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub