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。

如何粘贴表格并保持从Excel到Powerpoint的格式化？

1 个答案: