パワーポイントにExcelデータを貼り付ける方法とデータを編集できるようにする

Question

ユーザーが結果を編集できるようにしながら、エクセル範囲をパワーポイントにエクスポート/ペーストする方法があるのだろうかと思っていました。私がインターネット上で見ているコードは、パワーポイントからExcelのデータをペイントしてペーストします。以下はその例です：

Sub export_to_ppt(ByVal sheetname As String, ByVal initialSelection As String) ', ByVal cols As Integer, ByVal rows As Integer) 

Application.ScreenUpdating = False 
Dim rng As Range 
Dim PowerPointApp As Object 
Dim myPresentation As Object 
Dim mySlide As Object 
Dim myShape As Object 

'Copy Range from Excel 
'Set rng = ThisWorkbook.ActiveSheet.Range("B17:D50") 

'Create an Instance of PowerPoint 
On Error Resume Next 

'Is PowerPoint already opened? 
Set PowerPointApp = GetObject(class:="PowerPoint.Application") 

'Clear the error between errors 
Err.Clear 

'If PowerPoint is not already open then open PowerPoint 
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application") 

'Handle if the PowerPoint Application is not found 
If Err.Number = 429 Then 
    MsgBox "PowerPoint could not be found, aborting." 
    Exit Sub 
End If 

On Error GoTo 0 

'Optimize Code 
Application.ScreenUpdating = False 

'Create a New Presentation 
Set myPresentation = PowerPointApp.Presentations.Add 

'Add a slide to the Presentation 
Set mySlide = myPresentation.Slides.Add(1, 12) '12 = ppLayoutBlank 

'Copy Excel Range 

Dim rowCount As Integer 
Dim colcount As Integer 
Dim i As Integer 
Dim No_sheets As Integer 
No_sheets = Worksheets("Control_Sheet").Range("AP2").Value + 2 

For i = 3 To No_sheets 
Worksheets("Control_Sheet").Activate 
Worksheets("Control_Sheet").Cells(i, 42).Select 
    If Worksheets("Control_Sheet").Cells(i, 42).Value = sheetname Then 

     rowCount = Worksheets("Control_Sheet").Cells(i, 44).Value 
     colcount = Worksheets("Control_Sheet").Cells(i, 43).Value 
     GoTo resume_copy 
    End If 
Next i 

resume_copy: 
Worksheets(sheetname).Activate 
Worksheets(sheetname).Range(initialSelection).Select 
Selection.Resize(rowCount, colcount).Select 
Selection.Copy 


'Paste to PowerPoint and position 
Application.Wait Now + TimeValue("00:00:01") 
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile 
Set myShape = mySlide.Shapes(mySlide.Shapes.Count) 

'Set position: 
myShape.Left = 1 
myShape.Top = 1 
myShape.Width = 950 
PowerPointApp.Visible = True 
PowerPointApp.Activate 

Application.CutCopyMode = False 
Application.ScreenUpdating = True 

End Sub 

Answer 1

置き換えます

mySlide.Shapes.PasteSpecial DataType:=2 

で：これは役立ちます

mySlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, DisplayAsIcon:=msoFalse, link:=msoFalse 

希望、 TheSilkCode

Answer 2

大きなpptデッキを実行すると、このプロセスは非常にバグです。これは、ペーストの位置としてpptの形状の位置を使用することによって機能します。テストするには、テンプレートのpptスライドを使用して、この方法でテーブルやグラフを貼り付けることができます。

Dim myApp As PowerPoint.Application 
    Dim myPres As PowerPoint.Presentation 
    Dim myStatsSlide As PowerPoint.Slide 

    Set myApp = New PowerPoint.Application 
    Set myPres = myApp.ActivePresentation 

    Set myStatsSlide = myPres.Slides(1) 

    Dim mySheet As Worksheet 
    Set mySheet = ActiveSheet 

    'Copy table as table, not image 
    Dim mySumTable As Range 
    Set mySumTable = mySheet.Range("A1:C5") 

    mySumTable.Copy 

    myStatsSlide.Shapes.Placeholders(1).Select 

    myPres.Windows(1).View.Paste 

    'Copy Chart, as chart not image 
    Dim monoChart As ChartObject 

    'MONO CHART 
    monoChart.Select 
    ActiveChart.ChartArea.Copy 

    Debug.Print monoChart.Name 


    myStatsSlide.Shapes.Placeholders(2).Select 

    myPres.Windows(1).View.Paste 

    Debug.Print monoChart.Name