[Q] Can't PasteSpecial Keeping Source Formatting from Excel to PowerPoint

[rafaelcadina]

Hiho, how you doin?

I've been working in this code these days and can't get it working. Excel keeps showing this message:

Run-time error '-2147188160 (80048240)':
Method 'PasteSpecial' of objects 'Shapes' failed

Here it goes the code i've been working so far:

Sub CopyToPPT()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim Sh As Shape
x = 0
y = 0
Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
For Each Sh In Sheet11.Shapes
    If Sh.TextFrame2.TextRange.Characters = "Lançamentos, rk por atributos" Or Sh.TextFrame2.TextRange.Characters = "Descontinuados, rk por atributos" Or Sh.TextFrame2.TextRange.Characters = "Lançamentos, rk receita" Or Sh.TextFrame2.TextRange.Characters = "Descontinuados, rk receita" Then
    Else
        Sh.Copy
        PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
        With PPSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoTrue)
            .Left = 500 - 20 * x
            .Top = 200 + 20 * y
        End With
    End If
    x = x + 1
    y = y + 1
Next Sh
End Sub

 

[jsotola]

this runs all way through without error

Sub CopyToPPT()
    
    Dim PPApp As PowerPoint.Application
    Dim PPPres As PowerPoint.Presentation
    Dim PPSlide As PowerPoint.Slide
    Dim Sh As Shape
    
    x = 0
    y = 0
    
    Set PPApp = GetObject(, "Powerpoint.Application")
    Set PPPres = PPApp.ActivePresentation
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    
        For Each Sh In Sheet1.Shapes
        
            Select Case Sh.TextFrame2.TextRange.Characters
                Case "Lançamentos, rk por atributos":
                Case "Descontinuados, rk por atributos":
                Case "Lançamentos, rk receita":
                Case "Descontinuados, rk receita":
                
                Case Else
                    Sh.Copy
    
                    With PPSlide.Shapes.PasteSpecial
                        .Left = 500 - 20 * x
                        .Top = 200 + 20 * y
                    End With
            End Select
    
            x = x + 1
            y = y + 1
        Next Sh
    
End Sub

 

[rafaelcadina]

jsotola, it runs like a charm but it doesn't keep source formatting (from Excel). Can you help me with a workaround?

Thank you!

this runs all way through without error

Sub CopyToPPT()
    
    Dim PPApp As PowerPoint.Application
    Dim PPPres As PowerPoint.Presentation
    Dim PPSlide As PowerPoint.Slide
    Dim Sh As Shape
    
    x = 0
    y = 0
    
    Set PPApp = GetObject(, "Powerpoint.Application")
    Set PPPres = PPApp.ActivePresentation
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    
        For Each Sh In Sheet1.Shapes
        
            Select Case Sh.TextFrame2.TextRange.Characters
                Case "Lançamentos, rk por atributos":
                Case "Descontinuados, rk por atributos":
                Case "Lançamentos, rk receita":
                Case "Descontinuados, rk receita":
                
                Case Else
                    Sh.Copy
    
                    With PPSlide.Shapes.PasteSpecial
                        .Left = 500 - 20 * x
                        .Top = 200 + 20 * y
                    End With
            End Select
    
            x = x + 1
            y = y + 1
        Next Sh
    
End Sub