VBA returning errors at random

[Rune PS]

I have a VBA code which i use to copy areas from excel sheets, into a powerpoint presentation as a linked image, and then resize and position correctly. While the code works most of the time, the code randomly returns the following error:

run-time error '-2147188160 (80048240)':
Shapes.pastespecial : Invalid request. The specified data type is unavailable.

The error happens randomly, sometimes when copying the first picture, sometimes when copying one of the last pictures, or sometimes not at all. Seemingly, there is no rythme or reason to when this error occurs.

Below is the code i use. i have slightly adjusted it, since the actual code i use repeats the same lines over and over, for diffrent slides and figures, due to diffrent figures needing to be positioned and sized differently. This code should give you the idea however: just imagine this same code repeating over and over.


Sub test()
'PURPOSE: Copy Excel Ranges and Paste them into the Active PowerPoint presentation slides as linked images, and position and size them properly
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

'Create a New Presentation
Set myPresentation = PowerPointApp.ActivePresentation


'Make PowerPoint Visible and Active
PowerPointApp.ActiveWindow.Panes(2).Activate
' Phase 1:
'List of PPT Slides to Paste to
MySlideArray = Array(4)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet101.Range("a5:h13"))
'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel Range
MyRangeArray(x).Copy

'Paste to PowerPoint
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=10, DisplayAsIcon:=msoFalse, Link:=msoTrue).Item(1)
'Position object, use position macro to find the correct position
shp.LockAspectRatio = msoFalse
shp.Left = 37
shp.Top = 113
shp.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
shp.ScaleWidth 0.8, msoFalse, msoScaleFromTopLeft
shp.LockAspectRatio = msoTrue

Next x

' Phase 8:
'List of PPT Slides to Paste to
MySlideArray = Array(31, 32, 33)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet16.Range("H3:P31"), Sheet17.Range("E3:T18"), Sheet53.Range("E3:T18"))
'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel Range
MyRangeArray(x).Copy

'Paste to PowerPoint
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=10, DisplayAsIcon:=msoFalse, Link:=msoTrue).Item(1)
'Position object, use position macro to find the correct position
shp.LockAspectRatio = msoFalse
shp.Left = 28
shp.Top = 73
shp.ScaleHeight 0.68, msoScaleFromTopLeft
shp.ScaleWidth 0.68, msoScaleFromTopLeft
shp.LockAspectRatio = msoTrue

Next x
'Transfer Complete
Application.CutCopyMode = False
ThisWorkbook.Activate
End Sub

<strike></strike>

Does anyone know why it randomly returns error messeages? Its become alot worse lately, making the code barely useable, which means i need to copy and position several 100 of figures manually.

<strike></strike>