Question

我想知道是否有一种方法可以将excel范围导出/粘贴到powerpoint中，同时仍允许用户编辑结果。我在互联网上看到的代码将excel中的数据粘贴到powerpoint中作为图片。以下是一个例子：

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

如何将Excel数据粘贴到powerpoint中，仍然允许用户编辑数据

2 个答案: