I have a weekly presentation that I'm trying to automate. Each week I delete all of the previous weeks contents and paste in the new data using a macro in excel. However I cannot figure out how to delete all of the previous contents. Note: I do not want to delete the slides, just the pictures that are on the slides.
Edited: Below is the code I use in excel to paste in the new data each week. This code is for a single slide. Is it possible to add code to delete the previous weeks data before pasting in the new data?
Sub PasteAltSummaryToDeck()
'PURPOSE: Copy alt summary page and paste into weekly deck'
Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then Exit
If PowerPointApp Is Nothing Then
MsgBox "PowerPoint Presentation is not open, aborting."
Exit Sub
End If
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Make PowerPoint Visible and Active
PowerPointApp.ActiveWindow.Panes(2).Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.ActivePresentation
'List of PPT Slides to Paste to
MySlideArray = Array(11)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet2.Range("F5:AS60"))
'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel Range
MyRangeArray(x).Copy
'Paste to PowerPoint and position
On Error Resume Next
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
On Error GoTo 0
'Center Object
With myPresentation.PageSetup
shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
End With
Next x
'Record the date & time of procedure execution
Range("ExportAltSumToPPT").Value = Format(Now(), "mm/dd/yy") & " - " &
Format(TimeValue(Now), "hh:mm AM/PM")
'Transfer Complete
Application.CutCopyMode = False
ThisWorkbook.Activate
MsgBox "Complete!"
End Sub
For deleting the content of slides via Excel, you can utilize the following code:
Option Explicit
Sub remove_previous_shapes_in_PPT()
Dim sl As PowerPoint.Slide, sl_cnt As Long, pr As Object, pr_name As String, ppt As Object
Dim i As Long, j As Long
Set ppt = GetObject(, "PowerPoint.Application")
Set pr = ppt.Presentations(1)
sl_cnt = pr.Slides.Count
For j = sl_cnt To 2 Step -1
Set sl = pr.Slides(j)
For i = sl.Shapes.Count To 1 Step -1
sl.Shapes(i).Delete
Next i
Next j
End Sub
This utilizes looping through the count of slides and a nested loop of going through the shapes within the slide. In my above code, I leave slide 1 alone (you can just change the loop for j to go to 1, not 2, if you want the first slide content removed).
Note the items labeled as Object versus those that are bound to PPT references. I didn't go through the steps of utilizing your particular PPT, as I typically deal with GetObject() for the active PPT window, having only 1 presentation open.
try this;
Sub deletepics()
'variables
Dim slide As slide
Dim y As Long
'loop through slides backwards and with the slides shapes if they are pictures then delete
For Each slide In ActivePresentation.Slides
For y = slide.Shapes.Count To 1 Step -1
With slide.Shapes(y)
If .Type = msoPicture Then
.Delete
End If
End With
Next
Next
End Sub
EDIT:If you want to delete images on only slides 14 to 2 you can do this. Ignore my comments they were wrong. But the below code will work for you.
Sub deletepics()
'variables
Dim slide As slide
Dim y As Long
'loop through slides backwards and with the slides shapes if they are pictures then delete
For y = ActivePresentation.Slides.Count To 2 Step -1
If y <> 14 Then
Set sldTemp = ActivePresentation.Slides(y)
For lngCount = sldTemp.Shapes.Count To 1 Step -1
With sldTemp.Shapes(lngCount)
If .Type = msoPicture Then
.Delete
End If
End With
Next
End If
Next
End Sub
Related
Have been working on this problem for days and cant figure it out. On line with ExecuteMso I get following error message Method "ExecuteMso" of object "_CommandBars" failed. I'm having difficulty to understand or find why.
Searched web for days.
Sub GenerateReport()
Dim Wapp As Object
'Launches word application
Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
Wapp.Activate
...
Call CreateChart(Wapp)
End Sub
'Procedure, chart in word
Sub CreateChart(Wapp As Object)
Dim FomtCh As Excel.ChartObject
Dim InlineShCount As Long
'Create reference to excel chart
Set FomtCh = ThisWorkbook.Sheets("Doc").ChartObjects(1)
'Copy from excel chart to word chart
FomtCh.Chart.ChartArea.Copy
'Counts number of shapes in word document
InlineShCount = ActiveDocument.InlineShapes.Count
'Paste without linking to excel chart and embeding copy in word file
Word.Application.CommandBars.ExecuteMso ("PasteExcelChartSourceFormatting")
Do '<~~ wait completion of paste operation
DoEvents
Loop Until ActiveDocument.InlineShapes.Count > InlineShCount
End Sub
Not all of the Ribbon commands exist in the legacy CommandBars collection.
To get a full listing of the available commands create a blank document in Word and run the code below (from Word).
Sub ListCommands()
Dim cbar As CommandBar
Dim cbarCtrl As CommandBarControl
For Each cbar In Application.CommandBars
For Each cbarCtrl In cbar.Controls
Selection.TypeText cbarCtrl.Caption & vbCr
Next cbarCtrl
Next cbar
End Sub
The problem I am trying to solve is to automate the copy and paste from Excel to powerPoint which at the moment is time consuming because we deal with lots of charts in different sheets. So I did some research online to see if anyone else tried or succeeded at the task and here is the fruits of the research. However, it doesn't fully satisfy my purposes because even though it successfully copies and pastes in to powerpoint, the ordering is messed up since it paste from oldest to newest.
I tried to used create a loop that starts in the last sheet to the first but having multiple charts per sheet still messed up the ordering in which I would like to see the charts displayed.
Sub chart_deliveryReverse()
'declaring all of the objects that will be used
Dim objPP, objPPFile, mySlide, myShape As Object
Dim DestinationPPT, button As String
Dim sht As Worksheet
Dim charts As Long
Dim counter, counter1 As Integer
Dim Xchart As Excel.ChartObject
'Message Box with a message giving the user Feedback
button1 = MsgBox("Creating PowerPoint")
'assign the objPP to powerPoint App
Set objPP = CreateObject("PowerPoint.Application")
'make it visible in the screen
objPP.Visible = True
'open specific powerPoint presentation
DestinationPPT = "location of powerPoint"
Set objPPFile = objPP.Presentations.Open(DestinationPPT)
'Loop that start from beginning to ended
For counter = 1 To Worksheets.Count Step 1
'Commnented loop that starts at the last sheet to the beginning
'For counter = Worksheets.Count To 1 Step -1
Set sht = Worksheets(counter)
'Locate Excel charts to paste into the new PowerPoint presentation
For Each Xchart In sht.ChartObjects
'Copy each Excel chart and paste it into PowerPoint
sht.Activate
Xchart.Select
ActiveChart.ChartArea.Copy
'Customizes the powerPoint first number being where to start inserting slides and second number the layout
Set mySlide = objPPFile.Slides.Add(2, 11) '11 = ppLayoutTitle
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
mySlide.Shapes.PasteSpecial DataType:=6
objPP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
objPP.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
mySlide.Shapes(1).TextFrame.TextRange.Text = Xchart.Chart.ChartTitle.Text
'Align the lastest stored shape
myShape.Left = 100
myShape.Top = 50
Next
Next
'Next
' Clean up
Set objPP = Nothing
Set objPPFile = Nothing
Set mySlide = Nothing
End Sub
It opens up the specified powerpoint and populates it with the charts from the excel sheets
I have a code, recently updated to Excel 2016 that has shown some strange malfunctions. After quite a lot of debugging, I found that one of the errors were caused by Excel failing to handle a image correctly.
The code below has a simple purpose, to copy a used part of a worksheet to an image, and then insert that image as a comment in a worksheet.
However, in order for the function to work properly in Excel 2016, I need to repeat the paste operation several times as you can see in the code.
The workaround is functional, but I believe that some degree of understanding of why is needed, and I would also prefer a more clean solution.
Public Sub CopySheetToComment(ReferenceSheet As Worksheet, Target As Range)
Dim rng As Range
Dim Sh As Shape
Dim pWidth As Single
Dim PHeight As Single
Dim cmt As Comment
Dim TempPicFile As String
Application.ScreenUpdating = True
' Path temporary file
TempPicFile = Environ("temp") & "\img.png"
' Define and copy relevant area
Set rng = ReferenceSheet.UsedRange
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
pWidth = rng.Width
PHeight = rng.Height
' Paste copied image to chart and then export to file
Dim C As Object
Set C = ReferenceSheet.Parent.Charts.add
Dim Ch As ChartObject
Set Ch = C.ChartObjects.add(Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
' Ugly solution that is working in Excel 2016....
Ch.Chart.Paste
DoEvents
Ch.Chart.Paste
DoEvents
Ch.Chart.Paste
Ch.Chart.Export TempPicFile
' Remove chart object
Dim Alerts As Boolean
Alerts = Application.DisplayAlerts
Application.DisplayAlerts = False
C.Delete
Application.DisplayAlerts = Alerts
' Remove old comment
On Error Resume Next
Target.Comment.Delete
On Error GoTo 0
Application.ScreenUpdating = True
' Add comment
Set cmt = Target.AddComment
Target.Comment.Visible = True
' Infoga bild till kommentar
With cmt.Shape
.Fill.UserPicture TempPicFile
.Width = pWidth * 1.33333
.Height = PHeight * 1.33333
End With
'Target.Comment.visible = False
End Sub
And to call it, this example works:
Sub test()
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("blad2")
CopySheetToComment ws, Range("D8")
End Sub
Theories on why this works but not DoEvents, or suggestions for proper code is requested.
Ran into similar problems after updating my Excel version. This is how I solved it:
Dim pChart As Chart 'will serve as a temporary container for your pic
rng.CopyPicture xlScreen, xlPicture 'using the rng you use in your code here
Set pChrt = Charts.Add
ActiveChart.ChartArea.Clear
With pChrt
.ChartArea.Parent.Select 'new for Excel 2016
.Paste
.Export Filename:=TempPicFile, Filtername:="PNG" 'TempPicFile is what you defined in your code, so path + file name
.Delete
End With
You can then use the PNG and paste it as you do, asigning a width/height to it.
Additionally, I would set Application.DisplayAlerts = Falseat the beginning of a sub and set it back to Truejust at the end - quicker and less hassle.
Also works with:
Dim Ch As ChartObject
'adding
Ch.Chart.Parent.Select
'then
Ch.Chart.Paste
'because Microsoft....
I am trying to create a loop to go through each picture in my slideshow and paste each picture's corresponding hyperlink in an excel document as a list
I would also like the loop to loop through the pictures in order from left to right (ie in this screenshot attached, select the upper left image (Target's ad), then the next image to the right (Rite-Aid's ad), then CVS's, then Walgreens', and then go to the next row which starts with Benadryl for Walgreens and repeat that process)
Here is the code I have thus far
'Code for getting hyperlinks of images in Powerpoint- and pasting into excel
Sub getLinks()
Dim pptSlide As Slide
Dim pptShape As Shape
Dim pptHLstring As String
Dim xlApp As Object
Dim xlWorkBook As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkBook = xlApp.Workbooks.Open("C:\Weekly Ad Recaps\Non-FSI\lookuptable Non FSI.xlsm")
i = 0
For Each pptSlide In ActivePresentation.Slides
For Each pptShape In pptSlide.Shapes
i = i + 1
If pptShape.Type = Shape Then
On Error Resume Next
xlWorkBook.Sheets("PPT H-Link Index").Range(Cells(i, 1)) = pptShape.Hyperlink.Address
On Error GoTo 0
End If
Next pptShape
DoEvents
Next pptSlide
End Sub
The slideshow has a dozen slides all formatted the exact same way.
A macro to streamline this process would cut down on my weekly workload significantly
Thanks in advance to anyone who can help!!
Basically, I'm trying to use a range in Excel to produce automatically a set of custom layouts in PowerPoint. Following this code, I'm able to loop throught all the shapes in a predefined range, copying those who are within predefined range to a custom layout in a newly created presentation.
My problem is anything it copies from Excel to Powerpoint becomes picture instead of shape.
Here's a part of my code:
Dim WS As Worksheet
Dim PPT As Object
Dim PRES As Object
Dim PPTlay As Object
Dim shp As Shape
Dim r as Range
Set WS = ActiveWorksheet
Set r = WS.Range("A1:L36")
'New PPT Presentation
On Error Resume Next
Set PPT = GetObject(class:="PowerPoint.Application")
On Error GoTo 0
If PPT Is Nothing Then Set PPT = CreateObject(class:="PowerPoint.Application")
Set PRES = PPT.Presentations.Add
PRES.PageSetup.SlideSize = ppSlideSizeOnScreen
'Delete all layouts in slideMaster
For i = PRES.SlideMaster.CustomLayouts.Count To 1 Step -1
PRES.SlideMaster.CustomLayouts(i).Delete
Next i
'Create new custom layout
Set PPTlay = PRES.SlideMaster.CustomLayouts.Add(PRES.SlideMaster.CustomLayouts.Count + 1)
'Delete all placeholders and shapes on newly created custom layout
For i = PPTlay.Shapes.Count To 1 Step -1
PPTlay.Shapes(i).Delete
Next i
'Loop through all shape in Excel range "r"
'Copy/paste to powerpoint custom Layout
For Each shp In WS.Shapes
If Not Intersect(WS.Range(shp.TopLeftCell, shp.BottomRightCell), r) Is Nothing Then
shp.Select
Selection.Copy
PPTlay.Shapes.Paste
i = PPTlay.Shapes.Count
PPTlay.Shapes(i).LEFT = shp.LEFT
PPTlay.Shapes(i).TOP = shp.TOP
End If
Next shp
I also tried to select all shapes in range, copy selection, then paste it in the presentation but the same problem occurred.
Any hint would be welcome.
Thanks!
Try
PPTlay.Shapes.PasteSpecial DataType:= ppPasteShape
instead of
PPTlay.Shapes.Paste