Excel 范围到 PowerPoint - 粘贴问题

Question

将范围从 Excel 粘贴到 PowerPoint 时遇到一些问题。我想将其保留为 Keepsource 格式:

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

尝试这个

pptApp.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault

这给出了相同的结果

pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")

ppPasteDefault 的值是 0所以你可以把

Const ppPasteDefault as Integer = 0

在您的代码顶部或使用

pptApp.ActiveWindow.View.PasteSpecial DataType:=0

编辑(评论跟进)

我已经改变了你的代码。使用它并告诉我是否有任何错误。这不使用 .Activate/.Select INTERESTING READ

尝试这个

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