I have created a code to export charts from Excel into a power point presentation. Each slide has three text boxes. Two of those text boxes are the same for each slide, but the content of one of them (the text box at the very top of the slide, which now has "Industry One" and "Industry Two") varies by slides.
I am wondering if there is a way to create a loop, where I can place the content/text of the text box("Industry One", "Industry Two", "Industry Three", etc.) in the Excel spreadsheet and then call for it in the code.
Also, is there a way to call for the private subs SlideTextBox and FormatPicture more efficiently? Right now, I have to call for them after each slide. Is there a way to do it once where it would work for all my slides?
I am copying a part of the code below, which would create 4 slides. The full presentation would have at least 20 slides, so I am looking to build a more efficient/flexible code.
Thanks for any ideas!!
Option Explicit
'Declaring necessary Power Point variables.
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer
Sub ChartsToPowerPoint_ForecastEvolution_PPT()
'Create new presentation and open IHS power point template
Set pptApp = New PowerPoint.Application
pptApp.Visible = msoCTrue
Set pptPres = pptApp.Presentations.Add
'Show the power point.
pptApp.Visible = True
'Activate the worksheet and copy the first chart.
Worksheets("go_34o").Activate
ActiveSheet.ChartObjects(2).Copy
'Create a slide for it and paste it.
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
pptSlide.Shapes.PasteSpecial ppPasteJPG
Call SlideTextBox
Call FormatPicture
Call isic34o
ActiveSheet.ChartObjects(1).Copy
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
pptSlide.Shapes.PasteSpecial ppPasteJPG
Call SlideTextBox
Call FormatPicture
Call isic34o
'Activate the worksheet and copy the first chart.
Worksheets("go_F").Activate
ActiveSheet.ChartObjects(2).Copy
'Create a slide for it and paste it.
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
pptSlide.Shapes.PasteSpecial ppPasteJPG
Call SlideTextBox
Call FormatPicture
Call isicf
ActiveSheet.ChartObjects(1).Copy
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
pptSlide.Shapes.PasteSpecial ppPasteJPG
Call SlideTextBox
Call FormatPicture
Call isicf
End Sub
Private Sub SlideTextBox()
With pptSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 116.5, 80, 494.75, 350.25).TextFrame.TextRange
.Text = "Change (delta) in 2015 growth rate from the previous (2014Q4)"
'.Text = ActiveSheet.Range("a1").Text
.ParagraphFormat.Alignment = ppAlignCenter
.Font.Name = "Tahoma (Headings)"
.Font.Size = 16
.Font.Bold = msoTrue
End With
With pptSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 20.95, 475, 250.75, 12).TextFrame.TextRange
.Text = "*Data label indicates forecast growth for 2015"
' .ParagraphFormat.Alignment = ppAlignCenter
.Font.Name = "Tahoma (Headings)"
.Font.Size = 10
.Font.Bold = msoTrue
End With
End Sub
Private Sub FormatPicture()
Dim j As Integer
For j = 1 To pptSlide.Shapes.Count
With pptSlide.Shapes(j)
'Picture position
If .Type = msoPicture Then
.Top = 157
.Left = 83
.Height = 522
.Width = 566
End If
End With
Next j
End Sub
Private Sub isic34o()
'Creates the top textbox with industry ISIC.
With pptSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 20, 50, 500, 35.25).TextFrame.TextRange
.Text = "Industry One"
'.Text = ActiveSheet.Range("a1").Text
.Font.Color = RGB(44, 123, 182)
.Font.Name = "Tahoma (Headings)"
.Font.Size = 20
.Font.Bold = msoTrue
End With
End Sub
Private Sub isicf()
'Creates the top textbox with industry ISIC.
With pptSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 20, 50, 500, 35.25).TextFrame.TextRange
.Text = "Industry Two"
.Font.Color = RGB(44, 123, 182)
.Font.Name = "Tahoma (Headings)"
.Font.Size = 20
.Font.Bold = msoTrue
End With
End Sub
Bookmarks