BVAmateur_12
09-06-2021, 02:36 AM
Hi all,
I am looking for a simple bit of VBA to help paste the text from a particular cell into the title of a ppt slide. My current code (below) loops through a table of data and exports the graph to individual powerpoint slides.
As the graphs make up a section of the slide, instead of having the chart title on the graph, I'd like it as text on the powerpoint slide. Is there a piece of code anyone knows of that I can add into my loop to help assist with this?
The chart title is always in cell ("A2"), and then loops through.
Sub Change_Graph_Print_To_PowerPoint()
'Declare Powerpoint Object Variables
Dim PPTSlide As Object
'Animate Full
Dim i As Integer
'Declare Excel Object Variable
Dim Chrt As ChartObject
'Declare text box as shape
Dim objTextBox As Shape
' Reference existing instance of PowerPoint
Set PPApp = GetObject("", "Powerpoint.Application")
PPApp.Activate
On Error GoTo 10
15 Set PPPres = PPApp.ActivePresentation
slidecount = PPPres.Slides.Count
GoTo 20
10 PPApp.Presentations.Add
GoTo 15
20 SldIndex = 1
'Create reference to chart to export
Set Chrt = Sheets("Export Charts to PPT").ChartObjects(1)
'Range of the number loop Number loop is the name of the variable
For numberloop = 1 To 80
'Changes Cell D1 to value after equal sign
ActiveSheet.Range("A1") = numberloop
ActiveSheet.Calculate
'ensures graph changes
Application.ScreenUpdating = True
DoEvents
DoEvents
'Put print chart code here single chart on active worksheet
'Copy the Chart
Chrt.CopyPicture _
Appearance:=xlPrinter, Format:=xlPicture
' Add a new slide
Set PPSlide = PPPres.Slides.Add(SldIndex, 12)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
'Paste Chart in the slide as picture
With PPSlide
'Paste and select the chart picture
.Shapes.Paste.Select
' Position pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Left = 5
PPApp.ActiveWindow.Selection.ShapeRange.Top = 30
PPApp.ActiveWindow.Selection.ShapeRange.Height = 450
PPApp.ActiveWindow.Selection.ShapeRange.Width = 350
PPApp.ActiveWindow.Selection.ShapeRange.ZOrder (msoSendToBack)
End With
'Brings back to the loop
Application.Wait (Now + TimeValue("0:00:01"))
SldIndex = SldIndex + 1
Next numberloop
End Sub
Thanks!
Sam
I am looking for a simple bit of VBA to help paste the text from a particular cell into the title of a ppt slide. My current code (below) loops through a table of data and exports the graph to individual powerpoint slides.
As the graphs make up a section of the slide, instead of having the chart title on the graph, I'd like it as text on the powerpoint slide. Is there a piece of code anyone knows of that I can add into my loop to help assist with this?
The chart title is always in cell ("A2"), and then loops through.
Sub Change_Graph_Print_To_PowerPoint()
'Declare Powerpoint Object Variables
Dim PPTSlide As Object
'Animate Full
Dim i As Integer
'Declare Excel Object Variable
Dim Chrt As ChartObject
'Declare text box as shape
Dim objTextBox As Shape
' Reference existing instance of PowerPoint
Set PPApp = GetObject("", "Powerpoint.Application")
PPApp.Activate
On Error GoTo 10
15 Set PPPres = PPApp.ActivePresentation
slidecount = PPPres.Slides.Count
GoTo 20
10 PPApp.Presentations.Add
GoTo 15
20 SldIndex = 1
'Create reference to chart to export
Set Chrt = Sheets("Export Charts to PPT").ChartObjects(1)
'Range of the number loop Number loop is the name of the variable
For numberloop = 1 To 80
'Changes Cell D1 to value after equal sign
ActiveSheet.Range("A1") = numberloop
ActiveSheet.Calculate
'ensures graph changes
Application.ScreenUpdating = True
DoEvents
DoEvents
'Put print chart code here single chart on active worksheet
'Copy the Chart
Chrt.CopyPicture _
Appearance:=xlPrinter, Format:=xlPicture
' Add a new slide
Set PPSlide = PPPres.Slides.Add(SldIndex, 12)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
'Paste Chart in the slide as picture
With PPSlide
'Paste and select the chart picture
.Shapes.Paste.Select
' Position pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Left = 5
PPApp.ActiveWindow.Selection.ShapeRange.Top = 30
PPApp.ActiveWindow.Selection.ShapeRange.Height = 450
PPApp.ActiveWindow.Selection.ShapeRange.Width = 350
PPApp.ActiveWindow.Selection.ShapeRange.ZOrder (msoSendToBack)
End With
'Brings back to the loop
Application.Wait (Now + TimeValue("0:00:01"))
SldIndex = SldIndex + 1
Next numberloop
End Sub
Thanks!
Sam