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/.SelectINTERESTING 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