Excel范围到PowerPoint – 粘贴问题

我有一些问题时粘贴从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