VBA - My copy functionality from Excel to powerpoint is not working properly. It doesn't seem to work all the time

Question

I am trying to run the following code but the copying functionality from Excel and pasting into Powerpoint is not working properly. I just want to paste the chart / table as a picture. Also the formatting of the title within Powerpoint does not seem to work.

Any help on this would be much appreciated.

Option Explicit


Sub ExportTable()

Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim xlTable As ListObject
Dim xlTableColumn As ListColumn
Dim xlTableRow As Range

Dim xlChartObject As ChartObject
Dim xlTableObject As ListObject
Dim xlRangeObject As Range

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape

Dim ObjectField As String
Dim ObjectFieldParts As Variant
Dim ObjectName As String
Dim ObjectSheet As String
Dim ObjectType As String

'grab the book
Set xlBook = ThisWorkbook

'set the sheet
Set xlSheet = xlBook.Worksheets("Export")

'Grab the Table
Set xlTable = xlSheet.ListObjects("ExportToPowerpoint")

'Create a new instance of Powerpoint
On Error Resume Next 'if there is an error it will continue looping

'Grab the Active PowerPoint application, if it's there
Set pptApp = GetObject(, "Powerpoint.Application")

'if the application isn't open it will return a 429 error
If Err.Number = 429 Then

'first clear the error
Err.Clear

'create a new instance of powerpoint
Set pptApp = New PowerPoint.Application

'make it visible
pptApp.Visible = True
' pptApp.Activate 'to bring the ppt to the front

End If

'create the presentation
Set pptPres = pptApp.Presentations.Add

'loop through each row in the table
For Each xlTableRow In xlTable.ListColumns("Object").DataBodyRange

'Grab the object field
ObjectField = xlTableRow.Value

'console log
Debug.Print "Exporting Object: " + ObjectField

'split the field
ObjectFieldParts = Split(ObjectField, "-")

'grab the object name, sheet and type
ObjectName = ObjectFieldParts(0)
ObjectSheet = ObjectFieldParts(1)
ObjectType = ObjectFieldParts(2)

'grab the sheet
Set xlSheet = xlBook.Worksheets(ObjectSheet)
xlSheet.Activate

'grab the object
If ObjectType = "ListObject" Then

'copy it
Set xlTableObject = xlSheet.ListObjects.Item(ObjectName)
xlTableObject.Range.Copy

ElseIf ObjectType = "ChartObject" Then

'copy it
Set xlChartObject = xlSheet.ChartObjects(ObjectName)
xlChartObject.Chart.ChartArea.Copy 'Picture appearance:=xlScreen, Format:=xlPicture
Debug.Print "Exporting Chart: " + xlChartObject

ElseIf ObjectType = "Range" Then

'copy it
Set xlRangeObject = xlSheet.Range(ObjectName)
xlRangeObject.Copy 'Picture appearance:=xlScreen, Format:=xlPicture

End If


'Pause the excel application to make sure the data makes it into the clipboard
Application.Wait Now + #12:00:01 AM#

'console log
Debug.Print "Adding Slide: " + CStr(xlTableRow.Offset(0, 1).Value)

'Add the slide to the presentation
Set pptSlide = pptPres.Slides.Add(xlTableRow.Offset(0, 1).Value, ppLayoutTitleOnly)


'Paste the Shape to the slide
pptSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'pptSlide.Shapes.PasteSpecial DataType:=ppPastePNG, link:=xlTableRow.Offset(0, 6).Value

'change the slide title
pptSlide.Shapes(1).TextFrame.TextRange = xlTableRow.Offset(0, 7).Value

'grab the shape
Set pptShape = pptSlide.Shapes(pptSlide.Shapes.Count)

'resize the shape
pptShape.Top = xlTableRow.Offset(0, 2).Value
pptShape.Width = xlTableRow.Offset(0, 3).Value
pptShape.Left = xlTableRow.Offset(0, 4).Value
pptShape.Height = xlTableRow.Offset(0, 5).Value

'reformat the title
pptShape(1).TextFrame.TextRange.Font.Size = 22
pptShape(1).TextFrame.TextRange.Font.Bold = True
pptShape(1).TextFrame.TextRange.Font.Color.RGB = RGB(192, 0, 0)

Next



End Sub

Answer 1

Use:

pptSlide.Shapes.PasteSpecial 2: DoEvents

I'd also recommend putting a DoEvents after your .Copy lines, not an Application.Wait line.