I have a master PowerPoint presentation that has ~60 slides.
I want to go through the entire deck and copy specific slides that have certain text. I can create an array with the key words that form the basis of the selection but cannot figure out how to copy the entire slide.
Below code is the result of foraging on the internet.
Sub selct()
Dim pres1 As PowerPoint.Presentation, pres2 As PowerPoint.Presentation,
pp As Object
Set pp = GetObject(, "PowerPoint.Application")
Set pres1 = pp.ActivePresentation
Set pres2 = pp.Presentations.Add
Dim i As Long, n As Long
Dim TargetList
'~~> Array of terms to search for
TargetList = Array("Agenda", "Review", "third", "etc")
'~~> Loop through each slide
For Each sld In pres1.Slides
'~~> Loop through each shape
For Each shp In sld.Shapes
'~~> Check if it has text
If shp.HasTextFrame Then
Set txtRng = shp.TextFrame.TextRange
For i = 0 To UBound(TargetList)
'~~> Find the text
Set rngFound = txtRng.Find(TargetList(i))
'~~~> If found
Do While Not rngFound Is Nothing
'~~> Set the marker so that the next find starts from here
n = rngFound.Start + 1
'~~> Chnage attributes
With rngFound.Font
.Bold = msoFalse
sld.Copy
pres2.Slides.Paste
'~~> Find Next instance
Set rngFound = txtRng.Find(TargetList(i), n)
End With
Loop
Next
End If
Next
Next
End Sub
The above copies the slides but not the formatting. Additionally, the slides get repeated such that the number of slides in the new presentation number that in the master presentation, when it should be a subset. For example, the master has 60 slides, and the new presentation also has 60 slides instead of 20, say.
How do I copy just the slides that have the specific words as in the target array and keep the formatting of the slides as well?
I think first you need to ensure that pres2 is using the same design template/theme as pres1. If pres2 is using a different theme, then the slides will reflect that theme. I don't recall how to do that without spending some time debugging it, but since you're starting from a blank presentation, probably this is easiest:
First, delete all slides from pres2:
Set pres2 = pp.Presentations.Add
Dim i as Long
For i = pres2.Slides.Count to 1 Step - 1
pres2.Slides(i).Delete
Next
Now you have an empty presentation, and Paste the slides from pres1 should preserve the layout/theme.
sld.Copy
pres2.Slides.Paste
Related
I need to extract data from text boxes in a PowerPoint presentation and put them in respective cells in an Excel worksheet.
I have searched but can't find a suitable work-around.
This code is to print the text from slides. I can't understand how to arrange it in Excel cells.
Dim oPApp As Object
Dim oSlide As Object
Dim oShape As Object
Set oPApp = GetObject(, "PowerPoint.Application")
For Each oSlide In oPApp.ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.Type = 1 Or oShape.Type = 14 Then
Debug.Print oShape.TextFrame.TextRange.Text
End If
Next oShape
Next oSlide
Set oPApp = Nothing
Example of slide (Input):
Example of sheet (Output):
Supposing you want it to be done from Excel module (it could be done from PowerPoint Module also), I just adding some codes & suggestions to your code. However it is to be mentioned while looping through Shapes in a PowerPoint Slide It generally comes in order of creation of the shape. So for maintaining proper sequence of the fields, you have to work out some way sort them according to their position (i.e. top, left property or any other criteria according to the presentation). Try
Dim oPApp As Object
Dim oSlide As Object
Dim oShape As Object
Dim Rw, StCol, Col, Sht As Long
Rw = 2 'Starting Row of Target excel data
StCol = 1 'Starting Column of Target excel data
Sht = 3 'Target Worksheet no.
Set oPApp = GetObject(, "PowerPoint.Application")
'It will only work for already opened active presentation
'It can also be suugested that first create a powerpoint object and then open desired preesntation fron the path
For Each oSlide In oPApp.ActivePresentation.Slides
Col = StCol
For Each oShape In oSlide.Shapes
If oShape.Type = 1 Or oShape.Type = 14 Then
' Debug.Print oShape.TextFrame.TextRange.Text
'Next line was added for putting the data into excel sheet
ThisWorkbook.Sheets(Sht).Cells(Rw, Col).Value =
oShape.TextFrame.TextRange.Text
End If
Col = Col + 1
Next oShape
Rw = Rw + 1
Next oSlide
Set oPApp = Nothing
however one word of caution msoTextBox type is 17 and type 14 is msoPlaceholder.
I've the following piece of code which exports excel sheets to powerpoint. In each sheet it takes the range from cells A1 and A2 and copies that range into powerpoint.
Now I want to add two functions, but I have no clue how to do this, so I am hoping anyone can help me with this?
1 - In sheets where only a table is included, the code does exactly what it's supposed to do. However in some sheets I've included a picture or a chart and these are not properly pasted in excel. (only a blank picture is copied in the powerpoint slide). Now I want to make a code that uses my input from cell "C1" to determine whether this slide needs to be pasted as an image or as a normal paste. I've tried to fix this but my code continuously gets an error. Is there any way that I can adjust this code so that I will get it working?
2 - The code now copies all worksheets, but I want it to start at sheet 7 and continue from there till the end. Thus skipping the first 6 worksheets. Does anyone have a clue how I can exclude these sheets in my VBA?
Sub PrintPPT()
'Step 1: Declare variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim MyRange As String
'Step 2: Open PowerPoint, add a new presentation and make visible
Set pp = CreateObject("PowerPoint.Application")
Set PPPres = pp.Presentations.Add
pp.Visible = True
'Step 3: Start the loop through each worksheet
For Each xlwksht In ActiveWorkbook.Worksheets
MyRange = xlwksht.Range("A1").Value & ":" & xlwksht.Range("A2").Value
xlwksht.Range(MyRange).Copy
'Step 4: Count slides and add new blank slide as next available slide number
'(the number 12 represents the enumeration for a Blank Slide)
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
PPSlide.Select
'Step 5: Paste the picture and adjust its position
PPPres.ApplyTemplate ("C:\Users\Template.potx")
Pastetype = xlwksht.Range("C1").Value
' Pastetype will be "PasteSpecial DataType:=2" for images
' Pastetype will be "Paste.Select" for normal
PPSlide.Shapes.pastetype '2 = ppPasteEnhancedMetafile
'pp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pp.ActiveWindow.Selection.ShapeRange.Top = 85
pp.ActiveWindow.Selection.ShapeRange.Left = 7.2
'pp.ActiveWindow.Selection.ShapeRange.Width = 600
'Step 6: Add the title to the slide then move to next worksheet
Next xlwksht
'Step 7: Memory Cleanup
pp.Activate
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing
End Sub
This is my first real attempt to create something in VBA, so be gentle please.
This is what I need my program to do:
Run from PPT and open an Excel file
Start at slide 1 and find a box that contains the words "iq_", if it
has those words then it will have numbers after it like so "iq_43"
or "iq_43, iq_56, iq_72".
find those words and numbers in the opened Excel file. Needs to
recognize that ", " means there is another entry.
Copy column containing words from ppt ie. "iq_43"
Paste a Table into ppt with those values
Do this for every slide
I'm having issues with my function at the bottom. This is where the program should be shifting to work in the opened excel file. The idea there is to go through the headers of each column and search for values that I have stored in "iq_Array". Once values are found, then copy rows below it into another array called "tble" (which will eventually be pasted onto the powerpoint slide as a table).
The code currently stops at
rng = Worksheets("Sheet1").Cells(1, i).Value
I'm not sure what I'm doing wrong here. Once fixed, will this is be able to be copied into an array?
Another part I believe I'm having trouble with is how to return the function values. I currently have
xlFindText(iq_Array, xlWB) = tble()
At the bottom of my function in order to call it as such in my main code. Is this the proper way to do it?
Public Sub averageScoreRelay()
'Create variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim pptSlide As Slide
Dim fileName As String
Dim Shpe As Shape
Dim pptText As String
Dim strArray As String
Dim pptPres As Object
Dim PowerPointApp As Object
Dim iq_Array
' Create new excel instance and open relevant workbook
Set xlApp = New Excel.Application
xlApp.Visible = True 'Make Excel visible
Set xlWB = xlApp.Workbooks.Open("C:\Users\pinlop\Desktop\Gate\Macro\averageScores\pptxlpratice\dummyavgscore.xlsx", True, False) 'Open relevant workbook
If xlWB Is Nothing Then ' may not need this if statement. check later.
MsgBox ("Error retrieving Average Score Report, Check file path")
Exit Sub
End If
'Is PowerPoint already opened?
'Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Make PPT visible
Set pptPres = PowerPoint.ActivePresentation
Set pptSlide = Application.ActiveWindow.View.Slide 'Set pptSlide = pptPres.Slides _
(PowerPointApp.ActiveWindow.Selection.SlideRange.SlideIndex) (different way of saying the same thing?)
'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable
For Each pptSlide In pptPres.Slides
'searches through shapes in the slide
For Each Shpe In pptSlide.Shapes
'Identify if there is text frame
If Shpe.HasTextFrame Then
'Identify if there's text in text frame
If Shpe.TextFrame.HasText Then
pptText = Shpe.TextFrame.TextRange
If InStr(1, pptText, "iq_") > 0 Then 'Identify if within text there is "iq_" All IQ's have to be formatted like this "iq_42, iq_43" for now
iq_Array = Split(pptText, ", ") 'Use function below to Set iq_Array to an array of all iq_'s in the text box
xlFindText(iq_Array, xlWB).Copy
pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse ' Paste the Array
End If
End If
End If
Next Shpe
Next pptSlide
End Sub
Function xlFindText(iq_Array, xlWB) 'This function works in excel and saves the column values into xlFindText(iq_Array, xlWB) to be pasted as a table into ppt
'SetsxlTextID = to the array of iq_'s
Dim i As Integer
Dim k As Integer
Dim activeWB As Excel.Workbook
Dim size As String
Dim rng As Range
Dim tble As Range
'for loop to go through values stored in array
size = UBound(iq_Array) - LBound(iq_Array)
For i = 0 To size 'loops through array values
For k = 1 To 200 'loops through cloumns
rng = Worksheets("Sheet1").Cells(1, i).Value
If rng = iq_Array(i) Then 'matches column value to iq_Array
Columns(k).Select
tble(i) = Selection.Copy 'saves a copy of the range into tble() array
End If
Next k
Next i
xlFindText(iq_Array, xlWB) = tble()
End Function
There are several problems with your code, I'll go from start to end, but it may well be I'm missing some.
(1)
Set pptSlide = Application.ActiveWindow.View.Slide
is pointless because directly afterwards you overwrite pptSlide with:
For Each pptSlide In pptPres.Slides
xlFindText
(2)
rng = Worksheets("Sheet1").Cells(1, i).Value
If you work with a different Office program than the one where the code runs in (here Excel from PPT), you always must fully qualify your objects. Don't use shortcuts like ActiveSheet without specifying the parent object (Excel application).
So this should be:
xlWB.Worksheets("Sheet1").Cells(1, i).Value
The same applies to Columns(k).
(3)
rng is a Range object. This doesn't go together with a cell value.
Either
Set rng = xlWB.Worksheets("Sheet1").Cells(1, i)
or
Dim varValue As Variant
varValue = xlWB.Worksheets("Sheet1").Cells(1, i).Value
(4)
tble(i) = Selection.Copy
This is not how Range.Copy works, please check the Excel Online Help.
You will have to change the logic of xlFindText - either return a column number from this function and do the Copy + Paste in the main function, or do both in xlFindText (then pass pptSlide as parameter).
I want to paste a named excel range to a content placeholder in powerpoint in a custom layout. I'm currently using code like this
ranger.Copy
currentPPT.ActiveWindow.View.GotoSlide ppt.slides.Count
activeSlide.shapes("Picture").Select msoTrue
ppt.Windows(1).View.PasteSpecial (ppPasteEnhancedMetafile)
It usually works but sometimes fails inexplicably. I have seen elsewhere on this site, here for example, saying to avoid using .Select method. Instead use something like
Dim oSh As Shape
Set oSh = ActivePresentation.Slides(9).Shapes.PasteSpecial(ppPasteEnhancedMetafile)(1)
However, I can't figure out how to use the second method to copy straight to a content placeholder. Is that possible?
Edit, regarding Shai's suggestion. Current code is
For ii = activeSlide.shapes.Count To 1 Step -1
If activeSlide.shapes.Item(ii).Name = "Picture" Then
shapeInd = ii
Exit For
End If
Next ii
Set oSh = activeSlide.shapes.PasteSpecial(2, msoFalse)(shapeInd)
The "Picture" shape is a "Content" Placeholder. The other two shapes are text boxes.
The code below will do as you mentioned in your post.
First it creates all the necessary PowerPoint objects, including setting the Presentation and PPSlide.
Afterwards, it loops through all Shapes in PPSlide, and when it finds the Shape with Name = "Picture" it retrieves the index of the shape in that sheet, so it can Paste the Range object directly to this Shape (as Placeholder).
Code
Option Explicit
Sub ExporttoPPT()
Dim ranger As Range
Dim PPApp As PowerPoint.Application
Dim PPPres As Presentation
Dim PPSlide As Slide
Dim oSh As Object
Set PPApp = New PowerPoint.Application
Set PPPres = PPApp.Presentations("PPT_TEST") ' <-- change to your open Presentation
Set PPSlide = PPPres.Slides(9)
Set ranger = Worksheets("Sheet1").Range("A1:C5")
ranger.Copy
Dim i As Long, ShapeInd As Long
' loop through all shapes in Slide, check for Shape Name = "Picture"
For i = PPSlide.Shapes.Count To 1 Step -1
If PPSlide.Shapes.Item(i).Name = "Picture" Then
ShapeInd = i '<-- retrieve the index of the searched shape
Exit For
End If
Next i
Set oSh = PPSlide.Shapes.PasteSpecial(2, msoFalse)(ShapeInd) ' ppPasteEnhancedMetafile = 2
End Sub
I have a powerpoint presentation with an excel workbook embedded in one of the slides. I also have a userform that I want the user to input information into, I want to take this information and then edit the excel sheet with the relevant information.
I don't know how to access the excel sheet within powerpoint though so I can change the values of the cells.
Sub a()
Dim oSl As PowerPoint.Slide
Dim oSh As PowerPoint.Shape
Set oSl = ActivePresentation.Slides(1)
Set oSh = oSl.Shapes(1)
With oSh.OLEFormat.Object.Sheets(1)
.Range("A1").Value = .Range("A1").Value + 1
.Range("A2").Value = .Range("A2").Value - 1
End With
Set oSl = Nothing
Set oSh = Nothing
End Sub
Inspired in this code