Hey everyone, looking for some help with updating the code below. The code works fine in regards to copying specific ranges on multiple worksheets and exporting it to an existing powerpoint template. The problem I have now is each range i.e. rng_1, rng_2 are different sizes so it requires some manual updating to make sure the slides are readable and centered. Is there a way to autofit the range within the spreadsheet? Is a better solution to call out where the range should be pasted for each cell? What's the most efficient way to do that?
Thanks in advance for any help
Thanks in advance for any help
VBA Code:
Sub excelrangetopowerpoint_month()
Dim powerpointapp As Object
Set powerpointapp = CreateObject("powerpoint.application")
Dim destinationPPT As String
destinationPPT = ("Location for File")
On Error GoTo ERR_PPOPEN
Dim mypresentation As Object
Set mypresentation = powerpointapp.Presentations.Open(destinationPPT)
On Error GoTo 0
Application.ScreenUpdating = False
PasteToSlide mypresentation.Slides(5), Worksheets("Account Summary").Range("rng_1")
PasteToSlide mypresentation.Slides(4), Worksheets("Account Overview").Range("rng_13")
PasteToSlide mypresentation.Slides(8), Worksheets("Success Metrics").Range("rng_2")
PasteToSlide mypresentation.Slides(6), Worksheets("Financial - Pan ").Range("rng_3")
PasteToSlide mypresentation.Slides(11), Worksheets("Financial - C").Range("rng_4")
PasteToSlide mypresentation.Slides(14), Worksheets("Financial - M").Range("rng_6")
PasteToSlide mypresentation.Slides(17), Worksheets("Financial - N").Range("rng_5")
PasteToSlide mypresentation.Slides(7), Worksheets("Contract - Pan ").Range("rng_7")
PasteToSlide mypresentation.Slides(12), Worksheets("Contract - C").Range("rng_8")
PasteToSlide mypresentation.Slides(18), Worksheets("Contract - N").Range("rng_9")
PasteToSlide mypresentation.Slides(15), Worksheets("Contract - M").Range("rng_10")
PasteToSlide mypresentation.Slides(9), Worksheets("Stakeholder Summary").Range("rng_11")
PasteToSlide mypresentation.Slides(10), Worksheets("Program Tracker").Range("rng_12")
'duplicate this line for all slides/ranges
'PasteToSlide mypresentation.Slides(2), Worksheets("objectives").Range("m2")
powerpointapp.Visible = True
powerpointapp.Activate
Application.CutCopyMode = False
ERR_PPOPEN:
Application.ScreenUpdating = True 'don't forget to turn it on!
If Err.Number <> 0 Then
MsgBox "Failed to open " & destinationPPT, vbCritical
End If
End Sub
Private Sub PasteToSlide(mySlide As Object, rng As Range)
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = enhanced metafile
Dim myShape As Object
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = 278
myShape.Top = 175
End Sub