如何粘貼表格並保持格式從Excel到Powerpoint？

Question

我正在嘗試將表格從Excel粘貼到Powerpoint，並保持源格式（作為表格）。

當前正在使用它來粘貼：

'Paste to PowerPoint and position
 mySlide.Shapes.PasteSpecial DataType:=ppPasteSourceFormatting,    DisplayAsIcon:=msoFalse
 Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)

這以前是可行的，但當時我沒有選擇動態范圍並從中創建表，該表已經存在並且此代​​碼可以正常工作。

我今天已經嘗試了許多不同的方法，但是我對VB的了解還不足以解決問題。 希望有人可以成為我的救星！

整個代碼如下：

Sub ExcelRangeToPowerPoint()

'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation

Dim rng As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape

'Refresh UsedRange (get rid of "Ghost" cells)
  Worksheets("Task List1").UsedRange

'Select UsedRange
  Worksheets("Task List1").UsedRange.Select


    ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.UsedRange, , xlYes).Name = "Table1"
    Range("Table1[#All]").Select

    ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleMedium9"
    Range("I10").Select

'Copy Range from Excel
  Set rng = ActiveSheet.ListObjects(1).Range

'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

'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Open("Y:\Projects\VBa\2932 2 Milestones.pptx")

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

'Delete Current table from Powerpoint
  myPresentation.Slides(1).Shapes(2).Delete

'Wait for a few seconds to catch up
  Application.Wait (Now + TimeValue("0:00:3"))

'Copy Excel Range
  rng.Copy
  'ActiveSheet.ListObjects(1).Range.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=ppPasteSourceFormatting, DisplayAsIcon:=msoFalse
  'PowerPointApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
  Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)

    'Set position:
      myShapeRange.Left = 20
      myShapeRange.Top = 100
      myShapeRange.Height = 400
      myShapeRange.Width = 675

'Clear The Clipboard
  Application.CutCopyMode = False

End Sub

Answer 1

我發布此郵件是因為你們大多數人可能會笑：

在使用VB做有趣的事情之前，它有助於將工作簿另存為一個啟用的宏。

是的，我做了facepalm。