I've written a piece of code to copy data from excel and paste it in a powerpoint presentation.
I constantly get the following error:
Selection.ShapeRange : Invalid Request. Nothing Appropriate is
currently selected
Which relates to the following part of the code (where I am pasting the Excel data to the powerpoint slide and determine its position).
PPSlide.Shapes.PasteSpecial DataType:=2
pp.ActiveWindow.Selection.ShapeRange.Top = 0
pp.ActiveWindow.Selection.ShapeRange.Left = 0
pp.ActiveWindow.Selection.ShapeRange.Width = 1000
The weird thing is that this code used to work a couple of weeks ago (in excel 2016), but since today (I got downgraded to Excel 2010) it suddenly stopped working..
The full code I am using is as follows:
'Step 1: Declare variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim MyRange As String
Dim MyRange2 As String
Dim TemplatePath 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
'Step 3-A: Skip Excel sheets 1 till 8
For Each xlwksht In Worksheets
If xlwksht.Index >= 9 Then
'Step 3-B: Count slides and add new blank slide as next available slide number
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
PPSlide.Select
'Step 4: Copy the Content section from Excel
MyRange = xlwksht.Range("A1").Value & ":" & xlwksht.Range("A2").Value
xlwksht.Range(MyRange).Copy
'Step 5: Paste the Content and adjust its position
'Step 5-A: Determine the Path of the Template and apply it to the Powerpoint presentation
PPPres.ApplyTemplate (TemplatePath & "\Template.potx")
'Step 5-B: Determine the PasteType
pastetype = xlwksht.Range("C1").Value 'Where C1 = "Image" for all images and tables
PasteWidth = xlwksht.Range("D1").Value 'Where D1 = "Title" then picture will fill whole screen
'Step 5-C: Based on the Pastetype paste the content in the presentation
If pastetype = "Image" Then
If PasteWidth = "Title" Then
'Step 5-C-1 Format only for Title Page
PPSlide.Shapes.PasteSpecial DataType:=2
pp.ActiveWindow.Selection.ShapeRange.Top = 0
pp.ActiveWindow.Selection.ShapeRange.Left = 0
pp.ActiveWindow.Selection.ShapeRange.Width = 1000
Else
'Step 5-C-2 Format for Images
PPSlide.Shapes.PasteSpecial DataType:=2
pp.ActiveWindow.Selection.ShapeRange.Top = 95
pp.ActiveWindow.Selection.ShapeRange.Left = 20
pp.ActiveWindow.Selection.ShapeRange.Width = 300
End If
Else
'Step 5-C-3 Format for Normal tables
PPSlide.Shapes.Paste.Select
pp.ActiveWindow.Selection.ShapeRange.Top = 95
pp.ActiveWindow.Selection.ShapeRange.Left = 20
End If
This may or may not be the answer but plugging the suggestion in here will make it a whole lot more legible than including it as a comment:
Instead of this:
PPSlide.Shapes.PasteSpecial DataType:=2
pp.ActiveWindow.Selection.ShapeRange.Top = 0
pp.ActiveWindow.Selection.ShapeRange.Left = 0
pp.ActiveWindow.Selection.ShapeRange.Width = 1000
Try this:
With PPSlide.Shapes.PasteSpecial DataType:=2
.Top = 0
.Left = 0
.Width = 1000
End With
Related
I'm calling procedure from my main procedure to make header in word, that contains 2 lines of text, then image, then 1 line of text. I'm trying to do that with table that has 1 column and 4 rows. In 3rd row I want picture. Picture is stored on sheet in excel file, that contains all data for report in word. Paste is not working. Can't figure out how to get image in cell.
Found that picture can be added from file, but I don't want to keep picture in separate file, because if I move my excel file I have to move picture file also.
'Procedure, to create header
Sub MakeHeader()
Dim StrArr(1 To 2) As String
Dim RangeObj As Word.Range
'load text from excel table
StrArr(1) = ActiveSheet.Range("A26").Value
StrArr(2) = ActiveSheet.Range("A27").Value
'to create table
Set RangeObj = ActiveDocument.Sections(1).Headers(1).Range
RangeObj.Tables.Add Range:=RangeObj, NumRows:=4, NumColumns:=1
'populate table
'//
RangeObj.Tables(1).Cell(1, 1).Range.Text = StrArr(1)
RangeObj.Tables(1).Cell(2, 1).Range.Text = StrArr(2)
'copy picture that is embedded in excel sheet
'Shapes(4), because there are more then one object in sheet
ActiveSheet.Shapes(4).CopyPicture xlScreen, xlBitmap
RangeObj.Tables(1).Cell(3, 1).Application.Selection.Paste
'//
'center
ActiveDocument.Sections(1).Headers(1).Range.ParagraphFormat.Alignment = 1
End Sub
The main issue in the code is in the line
RangeObj.Tables(1).Cell(3, 1).Application.Selection.Paste
The Picture is getting pasted in the document itself as it is being referred to Application object selection (normally it is not in the header table but in the main document). So changing the line to
RangeObj.Tables(1).Cell(3, 1).Range.Paste
would paste it in the header table as shown below
Also instead of referring ActiveDocument directly in excel VBA (causing problem in some instances of run) it may be referred via Word Application.
The Full modified code:
Sub MakeHeader()
Dim StrArr(1 To 2) As String
Dim RangeObj As Word.Range
'Next line Added for test
Dim wd As Word.Application
'load text from excel table
StrArr(1) = ActiveSheet.Range("A26").Value
StrArr(2) = ActiveSheet.Range("A27").Value
'to create table
'Next Three line Added for test
Set wd = CreateObject("Word.Application")
wd.Visible = True
wd.Documents.Add
'Wd i.e. referance to Word application added to ActiveDocument
Set RangeObj = wd.ActiveDocument.Sections(1).Headers(1).Range
RangeObj.Tables.Add Range:=RangeObj, NumRows:=4, NumColumns:=1
'populate table
'//
RangeObj.Tables(1).Cell(1, 1).Range.Text = StrArr(1)
RangeObj.Tables(1).Cell(2, 1).Range.Text = StrArr(2)
'copy picture that is embedded in excel sheet
'Shapes(4), because there are more then one object in sheet
'shapes(4) modified to Shapes(1) for test. Change to Your requirement
ActiveSheet.Shapes(1).CopyPicture xlScreen, xlBitmap
'This line was causing Problem as Range.Application was referring to Word application
' And picture is getting pasted in the document not in header Table
RangeObj.Tables(1).Cell(3, 1).Range.Paste
'//
'center
'Wd i.e. referance to Word application added to ActiveDocument
wd.ActiveDocument.Sections(1).Headers(1).Range.ParagraphFormat.Alignment = 1
End Sub
Try:
Sub MakeWordHeader()
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim wdRng As Word.Range, wdTbl As Word.Table
Dim xlSht As Excel.Worksheet: Set xlSht = ActiveSheet
With wdApp
.Visible = True
Set wdDoc = .Documents.Add
With wdDoc
Set wdRng = .Sections(1).Headers(1).Range
Set wdTbl = .Tables.Add(Range:=wdRng, NumRows:=4, NumColumns:=1)
With wdTbl
.Cell(1, 1).Range.Text = xlSht.Range("A26").Text
.Cell(2, 1).Range.Text = xlSht.Range("A27").Text
xlSht.Shapes(4).CopyPicture xlScreen, xlBitmap
.Cell(3, 1).Range.Paste
End With
wdRng.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
End With
End Sub
For someone in future that wants to do something similar, but without Table
'Procedure, to create header
Sub MakeHeader(WApp As Object)
Dim StrArr(1 To 3) As String
Dim ImageObj As Excel.Shape
Dim Doc As Word.Document
Dim i As Long
Dim Count As Long
'load text from excel file
StrArr(1) = ActiveSheet.Range("A26").Value
StrArr(2) = ActiveSheet.Range("A27").Value
StrArr(3) = ActiveSheet.Range("A28").Value
'create object to hold picture
Set ImageObj = ActiveSheet.Shapes(4)
Set Doc = WApp.ActiveDocument
With Doc.Sections(1).Headers(1).Range
'centers text
.ParagraphFormat.Alignment = 1
'choosing font
.Font.Name = "Verdana"
.Font.Size = 9
'writes text
.InsertAfter StrArr(1)
.Paragraphs.Add
.InsertAfter StrArr(2)
.Paragraphs.Add
'creates space for image
For i = 1 To 8
.InsertAfter vbNullString
.Paragraphs.Add
Next
.InsertAfter StrArr(3)
'change font size for paragraphs 1 and 2
.Paragraphs(1).Range.Font.Size = 10
.Paragraphs(2).Range.Font.Size = 10
'copies image form excel file
With ImageObj
.Copy
End With
'collapses selection, 0 = wdCollapseEnd
.Collapse Direction:=0
'paste image, 3 = wdPasteMetafilePicture
.PasteSpecial DataType:=3
'centers image
.ShapeRange.Align msoAlignCenters, True
'lowers it from top of page
.ShapeRange.Top = 35
End With
'counts words in header
Count = Doc.Sections(1).Headers(1).Range.Words.Count
'underlines last two words, count considers ".", "#" and etc. as words
With Doc.Sections(1).Headers(1).Range
.Words(Count - 1).Font.Underline = 1
.Words(Count - 2).Font.Underline = 1
.Words(Count - 3).Font.Underline = 1
.Words(Count - 4).Font.Underline = 1
.Words(Count - 5).Font.Underline = 1
.Words(Count - 6).Font.Underline = 1
.Words(Count - 7).Font.Underline = 1
'don't need to underline comma ","
.Words(Count - 9).Font.Underline = 1
.Words(Count - 10).Font.Underline = 1
.Words(Count - 11).Font.Underline = 1
.Words(Count - 12).Font.Underline = 1
.Words(Count - 13).Font.Underline = 1
.Words(Count - 14).Font.Underline = 1
.Words(Count - 15).Font.Underline = 1
End With
End Sub
I am pasting some excel data into powerpoint as a picture and I am having some issues. I have 290 files which I am pasting a table into slide 4, 5 and 6 of each PP file. This worked perfectly yesterday when I was only doing 1 table into slide 6. I have replicated the process and now I keep getting random errors at random times. Sometimes its file 10, others file 50, different everytime. The errors range from the paste datatype is not available OR the clipboard is empty. I have tried every datatype, pasting as a metafile, as a shape, as a picture, just basic pasting and nothing stops the error. I have no idea! Here is my code: PLEASE HELP !
Sub Update_Site_Report()
'Initiate Variables
Dim objPPT As Object
Dim PPTPrez As Object
Dim FinSlide As Object
Dim AssumSlide As Object
Dim RiskSlide As Object
Dim FinTable As Object
Dim AssumTable As Object
Dim RiskTable As Object
Dim fileNameString As String
Dim PicCount As Long
Dim PicCount1 As Long
Dim PicCount2 As Long
Dim i As Long
Dim fileN As String
Dim Directory As String
'Create and open powerpoint application
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Application.ScreenUpdating = False
'Update site report table from spreadsheet
For i = 2 To 291
Sheet20.Cells(18, 2) = Sheet20.Cells(5, i)
Sheet20.Cells(19, 2) = Sheet20.Cells(6, i)
Sheet20.Cells(20, 2) = Sheet20.Cells(7, i)
Sheet20.Cells(21, 2) = Sheet20.Cells(8, i)
Sheet20.Cells(18, 3) = Sheet20.Cells(10, i)
Sheet20.Cells(19, 3) = Sheet20.Cells(11, i)
Sheet20.Cells(20, 3) = Sheet20.Cells(12, i)
Sheet20.Cells(21, 3) = Sheet20.Cells(13, i)
'Take column header from spreadsheet and set as filename
fileN = Sheet20.Cells(4, i)
' Allow directory to be set in excel tab
Directory = Sheet20.Cells(18, 5)
'Open powerpoint presentation at Directory with Filename
Set PPTPrez = objPPT.Presentations.Open(Directory & fileN & ".pptx")
'Set range for site report table
Set Financials = Sheet20.Range("A17:C21")
Set Assumptions = Sheet45.Range("A1:C7")
Set Risks = Sheet45.Range("A24:D41")
'Choose which slide to paste site report table
Set FinSlide = PPTPrez.Slides(6)
Set AssumSlide = PPTPrez.Slides(4)
Set RiskSlide = PPTPrez.Slides(5)
'If there is a table in powerpoint slide, delete the table
For PicCount1 = AssumSlide.Shapes.Count To 1 Step -1
If AssumSlide.Shapes(PicCount1).Type = msoPicture Then
AssumSlide.Shapes(PicCount1).Delete
End If
Next
For PicCount = FinSlide.Shapes.Count To 1 Step -1
If FinSlide.Shapes(PicCount).Type = msoPicture Then
FinSlide.Shapes(PicCount).Delete
End If
Next
For PicCount2 = RiskSlide.Shapes.Count To 1 Step -1
If RiskSlide.Shapes(PicCount2).Type = msoPicture Then
RiskSlide.Shapes(PicCount2).Delete
Debug.Print
End If
Next
'Paste the site report table into the site report
Financials.Copy
FinSlide.Shapes.PasteSpecial ppPasteShape
Set FinTable = FinSlide.Shapes(FinSlide.Shapes.Count)
Assumptions.Copy
AssumSlide.Shapes.PasteSpecial ppPasteShape
Set AssumTable = AssumSlide.Shapes(AssumSlide.Shapes.Count)
Risks.Copy
RiskSlide.Shapes.PasteSpecial ppPasteShape
Set RiskTable = RiskSlide.Shapes(RiskSlide.Shapes.Count)
'Set position of site report table in powerpoint
FinTable.Left = 36
FinTable.Top = 175
FinTable.Width = 614
AssumTable.Left = 36
AssumTable.Top = 80.8
RiskTable.Left = 36
RiskTable.Top = 80.8
RiskTable.Width = 641.5
'Set filename as string
fileNameString = Directory & fileN & ".pptx"
'Save file as filename
PPTPrez.SaveAs fileNameString
'Close powerpoint presentation
PPTPrez.Close
'Repeat for every site (column) - increment i
Next i
'quit powerpoint
objPPT.Quit
Application.ScreenUpdating = True
MsgBox ("Update complete, click ok to exit powerpoint")
End Sub
Disabling Windows clipboard history solves this issue.
I have created a template on excel which is populated with data for a specific country. The template contains 3 tables and a chart (line graph). I have a list of countries that I need to loop through, and for each loop, I need to create a powerpoint slide made up of the 3 tables and chart.
I build the macro below using bits from various sources (mostly from this platform). The macros scales and positions each of the elements. The first slide populates correctly, but I am running into the following issues:
All the tables and charts are positioned correctly on the first slide, but are not being positioned on every other slide. Note that the objects are still being scaled correctly
I get Run-time error ‘-214788160 (80048240): Selection (unknown member) : Invalid request. This view does not support selection
Does anyone have any suggestions for what the issue could be?
Sub MulipleCountrySlides()
'Step 1: Declare your variables
Dim ListOfSystems As Variant
Dim pptLayout As CustomLayout
Dim PP As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlides As PowerPoint.Slides
Dim PPSlide As PowerPoint.Slide
Dim SlideTitle As String
Dim XLS_Out As Variant
Dim shp As Object
Dim chtObj As ChartObject
Dim chtTop As Double
Dim chtLeft As Double
Dim chtWidth As Double
Dim chtHeight As Double
'Step 2: Open PowerPoint and create new presentation
Set PP = New PowerPoint.Application
Set PPPres = PP.Presentations.Add
PP.Visible = True
'Step 3: Add new slide as slide 1 and set focus to it
PPPres.ApplyTemplate "C:\Users\yogeswaran saravanan\AppData\Roaming\Microsoft\Templates\blank.potx"
ListOfSystems = Range("listofsystemstest") 'This is the list of systems that I will be looping through
For y = LBound(ListOfSystems) To UBound(ListOfSystems)
Set PPSlide = PPPres.Slides.Add(y, ppLayoutTitleOnly)
Worksheets("System output sheet").Range("j2").Value = ListOfSystems(y, 1)
Sheets("Indexed data").Calculate
ActiveSheet.Calculate
If Not Application.CalculationState = xlDone Then ' Calculation takes a while to run
DoEvents
End If
Set PPSlide = PPPres.Slides(y)
'The following arrays specify the regions/charts to be copied/pasted,
'the sizes/positions of these regions/charts, and the slide numbers corresponding
'to region/chart destinations
'Region/chart widths (Length/width ratios are preserved)
OWidth = Array(910, 450, 900, 465) '' 72px per Inch
OHeight = Array(400, 120, 33, 147)
'Horizontal positions on slides
OLeft = Array(22, 22, 22, 22)
'Vertical positions on slides
OTop = Array(100, 360, 504, 200)
'Regions and charts to be copied/pasted
XLS_Out = Array(Range("Countryslidetable"), _
Range("Chartdeltas"), _
Range("Countryfootnote"), _
Worksheets("System output sheet").ChartObjects("Chart 1"))
'Region/Chart type: 1 corresponds to chart objects, 0 corresponds to regions
XLS_OutFormat = Array(0, 0, 0, 1)
'Loop through arrays and copy/paste regions and charts one at a time
For x = 0 To 3 'LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel range/chart
XLS_Out(x).Copy
'Paste to PowerPoint
If (XLS_OutFormat(x) = 0) Then
'Paste an Excel range
Set shp = PPPres.Slides(y).Shapes.PasteSpecial(ppPasteHTML)
Else
'Paste an Excel chart
Set shp = PPPres.Slides(y).Shapes.PasteSpecial(ppPasteShape)
shp.LinkFormat.BreakLink
End If
'Change position/size of pasted regions/charts based on previously-defined arrays
With PPPres.Slides(y)
'shp.LockAspectRatio = msoTrue
shp.Height = OHeight(x)
shp.Width = OWidth(x)
shp.Top = OTop(x)
shp.Left = OLeft(x)
shp.ZOrder msoSendToFront
'End With
If (XLS_OutFormat(x) = 0) Then
If (x = 2) Then
PP.ActiveWindow.Selection.ShapeRange.TextEffect.FontSize = 10
End If
If (x = 0) Then
'Set oShp = PPSlide.Shapes(1)
'Set oShp = PP.ActiveWindow.Selection.ShapeRange
Set oTbl = shp.Table
For i = 1 To oTbl.Columns.Count
For J = 1 To oTbl.Rows.Count
'oShp.TextFrame.TextRange.Font.Size = 11
oTbl.Cell(J, i).Shape.TextFrame.TextRange.Font.Size = 11
Next
Next
End If
End If
End With
Next x
'Step 6: Add the title to the slide
SlideTitle = "Country Price Recommendations: " & Worksheets("System output sheet").Range("J2")
PPPres.Slides(y).Shapes.Title.TextFrame.TextRange.Text = SlideTitle
'Step 7: Memory Cleanup
PP.Activate
Next y
Set PPSlide = Nothing
Set PPPres = Nothing
Set PP = Nothing
End Sub
Looking for some help on updating a VBA Script that completes the following (basic algorithm):
Excel Template with formulas and macros creates a custom report consisting of approximately 30 charts
Macro called “CreatePowerPointPresentation” is used to transfer these charts into a specific PowerPoint template in specific format
The macros uses the slides contained in the template to create the first 6 slides
The macro then adds slides (transitions and content slides)
Note: This macro was actually created based on a feedback from this forum
This macro works great in Windows 7 with Office 2013, but generates errors in Windows 10, Office 2016 after slide 8 is created, randomly during one of the paste chart actions, but never gets past slide 10 of a 17-slide deck.
Errors:
Runtime Error '-2147188160 (80048240)
Method 'PasteSpecial'of object 'Shapes' failed.
Or
Runtime Error '-2147023170 (800706be)':
Automation Error
The Remote procedure call failed.
I'm not sure if this is an object issue or some other piece that I'm missing.
Code below:
Sub CreatePowerPointPresentation()
'=========================================================================
'Create PowerPoint Presentation
'Assigned to Index Tab
'==========================================================================
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim CHT As Excel.ChartObject
Dim fmt As String
Dim hgt As String
Dim wth As String
‘this code allows for the user to select whether to paste the charts as Excel Charts or PNG Formatted images.
Sheets("Index").Select
If Range("AB7").Value = "Excel Charts" Then
fmt = ppPasteDefault
Else
fmt = ppPastePNG
End If
'Establishes the global height and width of the graphics or charts pasted from Excel
hgt = 280
wth = 710
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
Application.EnableEvents = True
Application.ScreenUpdating = True
'Apply Template & Create Title Slide 1
newPowerPoint.ActivePresentation.ApplyTemplate Application.DefaultFilePath & "\file.potx"
'Set presentation to be 16x9
'AppActivate ("Microsoft PowerPoint")
With newPowerPoint.ActivePresentation.PageSetup
.SlideSize = ppSlideSizeOnScreen16x9
.FirstSlideNumber = 1
.SlideOrientation = msoOrientationHorizontal
.NotesOrientation = msoOrientationVertical
End With
'Create Slides 2-6 these are imported from the template
newPowerPoint.ActivePresentation.Slides.InsertFromFile Application.DefaultFilePath & "\File.potx", 0, 1
'Create Slide 7
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
newPowerPoint.ActivePresentation.Slides(7).CustomLayout = newPowerPoint.ActivePresentation.SlideMaster.CustomLayouts(33)
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
With newPowerPoint.ActivePresentation.Slides(7)
.Shapes("Title 1").TextFrame.TextRange.Text = "Title1"
End With
newPowerPoint.ActiveWindow.ViewType = ppViewSlide
‘Create Slide 8 – Quad Chart Slide
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
newPowerPoint.ActivePresentation.Slides(8).CustomLayout = newPowerPoint.ActivePresentation.SlideMaster.CustomLayouts(13)
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
newPowerPoint.ActivePresentation.Slides(8).Shapes("Title 1").TextFrame.TextRange.Text = "Title 1"
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
newPowerPoint.ActiveWindow.ViewType = ppViewSlide
'Upper Left
Sheets("Charts").Select
ActiveSheet.ChartObjects("Chart 3").Select
ActiveChart.ChartArea.Copy
newPowerPoint.ActiveWindow.ViewType = ppViewSlide
activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select
'Adjust the positioning of the Chart on Powerpoint Slide
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 5
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 75
newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145
newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 345
'Upper Right
Sheets("Charts").Select
ActiveSheet.ChartObjects("Chart 2").Select
ActiveChart.ChartArea.Copy
newPowerPoint.ActiveWindow.ViewType = ppViewSlide
activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 350
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 75
newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145
newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 345
'Lower Left
Sheets("Charts").Select
ActiveSheet.ChartObjects("Chart 4").Select
ActiveChart.ChartArea.Copy
newPowerPoint.ActiveWindow.ViewType = ppViewSlide
activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 5
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 230
newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145
newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 690
‘More slides……
Application.EnableEvents = True
Application.ScreenUpdating = True
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
This sounds like the dreaded code-runaway scenario I have faced in PowerPoint before where it takes more time to copy things to and paste things from the Windows clipboard than the VBA code execution and hence the VBA code runs ahead and fails as a result. To confirm that this is the cause, put some break points on the .Copy, .ViewType and .PasteSpecial lines and see if it still fails for your full slide collection. If not, try adding some DoEvents lines after the .Copy and .ViewType lines and if that doesn't help, inject a Delay of one or two seconds instead of the DoEvents. That will at least confirm if the hypothesis is true or not.
I am trying to mass-generate a series of PowerPoint presentations. My slide would contain two elements, both created and copied from Excel. I am using Office 2010.
The first element is a SmartArt graphic which is smoothly done. The second one is a few cells that I would like to copy as a Table object (instead of a linked image). After wasting a few hours with "Shapes", I found this, but I cannot manipulate its height and width after pasting.
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
Then, when I tried to save the presentation using the following, I realised only the SmartArt is saved; the pasted table is not saved even though the saveAs command occured after the paste.
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
PPPres.SaveAs saveName, ppSaveAsDefault
PPPres.Close
More bizarrely, I found that when I added a msgbox command for debugging above between paste and save, the table is saved correctly. However, I am trying to mass produce these files and cannot sit down to close each message box.
My questions:
1. How can I change the table's height/width/alignment after pasting?
2. How can I save my file with the table in it?
EDITED, my current code
Sub copyAllToPpt()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PPName, xlName As String
xlName = ActiveWorkbook.Name
Dim saveName As String
Workbooks(xlName).Activate
Dim y As Integer
y = ActiveCell.Row
saveName = ActiveSheet.Cells(y, "B").Value & "-" & ActiveSheet.Cells(y, "A").Value & " Stats"
Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True
Set PPPres = PPApp.Presentations.Add
PPName = PPPres.Name
PPApp.ActiveWindow.ViewType = ppViewSlide
Set PPSlide = PPPres.Slides.Add(1, ppLayoutBlank)
createSmartArtGraphicThenCopy
PPSlide.Shapes.Paste.Select
PPApp.ActiveWindow.Selection.ShapeRange.Height = 288
PPApp.ActiveWindow.Selection.ShapeRange.Width = 641
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoTrue
PPApp.ActiveWindow.Selection.Unselect
'Macro is working as expected up to here
Workbooks(xlName).Activate
createTable
'Table is copied in subroutine
PPApp.Activate
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
'Application.Wait (Now + TimeValue("0:00:05"))
'Tried the Wait() to no avail.
DoEvents: DoEvents: DoEvents
PPApp.ActivePresentation.SaveAs saveName, ppSaveAsDefault
PPApp.ActivePresentation.Close
End Sub
This works when I run it from within PPT; you'll need to adapt it by adding references to the PPT application object, etc:
Dim oSh As Object
Dim oSl As Object
Dim x As Long
x = 1 ' or whatever slide you want to work with
Set oSl = ActivePresentation.Slides(x)
CommandBars.ExecuteMso ("PasteSourceFormatting")
DoEvents: DoEvents: DoEvents
Set oSh = oSl.Shapes(oSl.Shapes.Count)
oSh.Left = 0
' etc
Without the DoEvents statements, it fails, in exactly the same way as your save problem fails. Unless you give PPT a few cycles to deal with the newly pasted shape, it thinks that it's not there.