Transfer Range from Excel to PPT using VBA

[proestas]

Hello

I have the following code which transfers specific ranges from excel to a new powerpoint presentation. Each range has a different slide.

Each of the slides have a specific title which I give by offsetting from a specific cell. I would like to change the font of that title (size and colour) and also I would like the background colour of all the powerpoint slides of my new presentation once the excel ranges are transferred in to change to Black.

I am not sure how to code the above in. I would appreciate your help.

Thanks!

Please see the code below:

Option Explicit


Dim PP As Object
Dim PP_File As Object
Dim PP_Slide As Object


Private Sub CopyandPastetoPPT(myRangeName As String, myTitle As String, myScaleHeight As Single, myScaleWidth As Single)
Dim NextShape As Integer
Dim ReportDate As String

ReportDate = Range("myReportDate").Value '& " / Week " & Range("myReportWeek").Value & " - "
Application.GoTo Reference:=myRangeName
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Range("A1").Select
PP.ActivePresentation.Slides.Add PP.ActivePresentation.Slides.Count + 1, 11
Set PP_Slide = PP_File.Slides(PP.ActivePresentation.Slides.Count)
PP_Slide.Shapes.Title.TextFrame.TextRange.Text = ReportDate & myTitle
NextShape = PP_Slide.Shapes.Count + 1
PP_Slide.Shapes.PasteSpecial 2
PP_Slide.Shapes(NextShape).ScaleHeight myScaleHeight, 1
PP_Slide.Shapes(NextShape).ScaleWidth myScaleWidth, 1
PP_Slide.Shapes(NextShape).Left = PP_File.PageSetup.SlideWidth \ 2 - PP_Slide.Shapes(NextShape).Width \ 2
PP_Slide.Shapes(NextShape).Top = 90
PP_Slide.Shapes(NextShape).Fill.BackColor.RGB = RGB(228, 0, 0)


End Sub


Sub ExportToPPT()
Dim ActFileName As Variant
Dim ScaleFactor As Single


On Error GoTo ErrorHandling
ActFileName = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.ppt), *.ppt")
ScaleFactor = Range("myScaleFactor").Value
Set PP = CreateObject("Powerpoint.Application")
If ActFileName = False Then
PP.Activate
PP.Presentations.Add
Set PP_File = PP.ActivePresentation
Else
PP.Activate
Set PP_File = PP.Presentations.Open(ActFileName)
End If
PP.Visible = True
CopyandPastetoPPT "myDashboard00", Range("myInputStartTitles").Offset(-1, 0).Value, ScaleFactor, ScaleFactor
CopyandPastetoPPT "myDashboard01", Range("myInputStartTitles").Offset(1, 0).Value, ScaleFactor, ScaleFactor
CopyandPastetoPPT "myDashboard02", Range("myInputStartTitles").Offset(2, 0).Value, ScaleFactor, ScaleFactor
CopyandPastetoPPT "myDashboard03", Range("myInputStartTitles").Offset(3, 0).Value, ScaleFactor, ScaleFactor
CopyandPastetoPPT "myDashboard04", Range("myInputStartTitles").Offset(4, 0).Value, ScaleFactor, ScaleFactor
CopyandPastetoPPT "myDashboard05", Range("myInputStartTitles").Offset(5, 0).Value, ScaleFactor, ScaleFactor
CopyandPastetoPPT "myDashboard06", Range("myInputStartTitles").Offset(6, 0).Value, ScaleFactor, ScaleFactor
CopyandPastetoPPT "myDashboard07", Range("myInputStartTitles").Offset(7, 0).Value, ScaleFactor, ScaleFactor
Set PP_Slide = Nothing
Set PP_File = Nothing
Set PP = Nothing
Worksheets(1).Activate
Exit Sub


ErrorHandling:


Set PP_Slide = Nothing
Set PP_File = Nothing
Set PP = Nothing
MsgBox "Error No.: " & Err.Number & vbNewLine & vbNewLine & "Description: " & Err.Description, vbCritical, "Error"


End Sub