Excel Range to PowerPoint - Paste Problems

Question

Im having some issues when pasting a Range from Excel to PowerPoint. I want to keep it as Keepsource format:

Function copyToPPT()

'Create an instance of PowerPoint.
Set pptApp = CreateObject("PowerPoint.Application")
' Create a PowerPoint presentation.
nomeppt = ThisWorkbook.Path + "\" + "SR-1871_R1 - ID-033 - Bi-Weekly LATAM QC Communication Meeting - data_Blank.pptx"

With pptApp
    Let .Visible = True
    Let .WindowState = 3
    Set Pres1 = pptApp.Presentations.Open(nomeppt)
End With


i = 8
While i <= 14
    slide = "Slide " & i & " Final"
    Workbooks("Results.xlsx").Activate
    Worksheets(slide).Activate
    Worksheets(slide).Range("A1").Select
    Worksheets(slide).Range(Selection, Selection.End(xlDown)).Select
    Worksheets(slide).Range(Selection, Selection.End(xlToRight)).Select 'Selecionando os registros - Simulando ctrl + shift baixo/direta
    Selection.Copy
    pptApp.ActiveWindow.View.GotoSlide Index:=i
    'pptApp.ActivePresentation.Slides(i).Shapes.PasteSpecial DataType:=7 - NOT THE FORMAT I WANT
    i = i + 1
    pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting") 'freeze the powerpoint when pasting...
    pptApp.CommandBars.ReleaseFocus

Wend

End Function

Answer 1

Try this

pptApp.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault

This give the same result as

pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")

Value of ppPasteDefault is 0 So you can either put

Const ppPasteDefault as Integer = 0

at the top of your code or use

pptApp.ActiveWindow.View.PasteSpecial DataType:=0

EDIT (Followup from comments)

I have changed your code. Use this and tell me if you get any error. This doesn't use .Activate/.Select INTERESTING READ

Try this

Sub copyToPPT()
    Dim lRow As Long, lCol As Long
    Dim LastCol As String
    Dim rng As Range

    'Create an instance of PowerPoint.
    Set pptApp = CreateObject("PowerPoint.Application")
    ' Create a PowerPoint presentation.
    nomeppt = ThisWorkbook.Path & "\" & _
    "SR-1871_R1 - ID-033 - Bi-Weekly LATAM QC Communication Meeting - data_Blank.pptx"

    With pptApp
        .Visible = True
        .WindowState = 3
        Set Pres1 = pptApp.Presentations.Open(nomeppt)
    End With

    i = 8

    While i <= 14
        slide = "Slide " & i & " Final"
        With Workbooks("Results.xlsx").Worksheets(slide)
            lRow = .Range("A" & .Rows.Count).End(xlUp).Row
            lCol = .Cells(1, Columns.Count).End(xlToLeft).Column

            LastCol = Split(.Cells(, lCol).Address, "$")(1)

            Set rng = .Range("A1:" & LastCol & lRow)
        End With

        pptApp.ActiveWindow.View.GotoSlide Index:=i

        rng.Copy

        DoEvents

        pptApp.ActiveWindow.Panes(2).Activate

        pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")

        Wait 3

        Application.CutCopyMode = False

        i = i + 1
    Wend
End Sub

Private Sub Wait(ByVal nSec As Long)
    nSec = nSec + Timer
    While nSec > Timer
        DoEvents
    Wend
End Sub