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!!
Related
With the following code, I'm able to collect data from a slide and sent them to an excel sheet.
Unfortunately, I have some data that are writen in one of the layout of the slide master.
Do you know how can I access to those shapes and collect them in the same excel sheet?
Sub ExportMultiplePowerPointSlidesToExcel()
Dim PPTPres As Presentation
Dim PPTSlide As Slide
Dim PPTShape As Shape
Dim PPTTable As Table
Dim PPTPlaceHolder As PlaceholderFormat
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlWrkSheet As Excel.Worksheet
Dim xlRange As Excel.Range
'Grab the Currrent Presentation.
Set PPTPres = Application.ActivePresentation
'Keep going if there is an error
On Error Resume Next
'Get the Active instance of Outlook if there is one
Set xlApp = GetObject(, "Excel.Application")
'If Outlook isn't open then create a new instance of Outlook
If Err.Number = 429 Then
'Clear Error
Err.Clear
'Create a new Excel App.
Set xlApp = New Excel.Application
'Make sure it's visible.
xlApp.Visible = True
'Add a new workbook.
Set xlBook = xlApp.Workbooks.Add
'Add a new worksheet.
Set xlWrkSheet = xlBook.Worksheets.Add
End If
'Set the Workbook to the Active
Set xlBook = xlApp.Workbooks("ExportFromPowerPointToExcel.xlsm")
'Set the Worksheet to the Active one, if Excel is already open.
Set xlWrkSheet = xlBook.Worksheets("Slide_Export")
'Loop through each Slide in the Presentation.
Set PPTSlide = ActivePresentation.Slides(1)
'Loop through each Shape in Slide.
For Each PPTShape In PPTSlide.Shapes
'If the Shape is a Table.
If PPTShape.Type = msoPlaceholder Or PPTShape.Type = ppPlaceholderVerticalObject Then
'Grab the Last Row.
Set xlRange = xlWrkSheet.Range("A20").End(xlUp)
'Handle the loops that come after the first, where we need to offset.
If xlRange.Value <> "" Then
'Offset by One rows.
Set xlRange = xlRange.Offset(1, 0)
End If
'Grab different Shape Info and export it to Excel.
xlRange.Value = PPTShape.TextFrame.TextRange
End If
Next
xlWrkSheet.Columns.ColumnWidth = 20
xlWrkSheet.Rows.RowHeight = 20
xlWrkSheet.Cells.HorizontalAlignment = xlLeft
xlApp.ActiveWindow.DisplayGridLines = False
End Sub
Thank you for your precious help
regards,
nicolas
You can access the master slide with the property SlideMaster. The data type is Master (not Slide). It has a Shape collection like a regular slide.
Dim PPTMaster As Master
Set PPTMaster = ActivePresentation.SlideMaster
For Each PPTShape In PPTMaster.Shapes
(...)
Next
If you want to avoid to duplicate your code that handles the shapes, put that part into a subroutine that gets either a single Shape or a Shape-Collection as parameter.
To get content from a particular layout:
Dim objLayout As CustomLayout
For Each objLayout In ActivePresentation.Designs(1).SlideMaster.CustomLayouts
If objLayout.Name = "Layout Name" Then
'Get the information here.
End If
Next objLayout
Even though the property name is CustomLayouts, the same code works for built-in Microsoft slide layouts as well.
I'm trying to automate the creation of a PowerPoint deck that I create a few times a week. I use a program called Alteryx to update the embedded excel files for all my charts in PowerPoint and that part works great. The problem that I have is that once I open PowerPoint, all the charts look the same as they originally were. It's only when I click edit data, that PowerPoint seems to read the excel changes and updates the chart. I have over 50 charts that I need to update, and clicking edit data on each one is very time consuming.
Is there a macro that can be created that will refresh all charts in my deck?
Thank you in advance for your time!
Update 1
I have tried using the following code from another post, but it results in 50 open workbooks.
Dim pptChart As Chart
Dim pptChartData As ChartData
Dim pptWorkbook As Object
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasChart Then
Set pptChart = shp.Chart
Set pptChartData = pptChart.ChartData
pptChartData.Activate
shp.Chart.REFRESH
On Error Resume Next
On Error GoTo 0
End If
Next
Next
Set pptWorkbook = Nothing
Set pptChartData = Nothing
Set pptChart = Nothing
I tried using the following code to open and close all the embedded workbooks, but it results in an error at this part "ActiveWindow.View.GotoSlide s.Slideindex"
Sub refreshchart()
Dim ppApp As PowerPoint.Application, sld As Slide
Dim s As PowerPoint.Shape
Dim gChart As Chart, i As Integer
ppApp.Visible = True
i = 3
Set sld = ActivePresentation.Slides(i)
sld.Select
For Each s In ActivePresentation.Slides(i)
If s.Type = msoEmbeddedOLEObject Then
s.Select 'select the object
s.OLEFormat.Activate 'Activate it (like 2x click))
ActiveWindow.Selection.Unselect 'To let it close
ActiveWindow.View.GotoSlide s.Slideindex 'make current slide active
End If
Next s
End Sub
A macro that opens the workbooks to refresh the charts and automatically closes them would be great. Thank you!
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
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
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