Question

帮助！我是VBA新手，正在尝试获取以下宏以将单元格从Excel工作表复制到PowerPoint幻灯片，然后重新格式化复制的单元格以更有效地适应Powerpoint。下面的代码有时可以工作，但其他情况下不工作。这是我不断收到的错误：

“ Shapes.PasteSpecial：无效的请求。剪贴板为空或包含了可能无法粘贴到此处的数据。”

衷心感谢所有帮助清除此代码并使其正常工作的人。

Sub ExcelRangeToPowerPoint()

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim pptSlide As Slide
Dim pptLayout As CustomLayout
Dim i As Integer
Dim r As Integer
Dim s As Integer
Dim Restart As String

i = 0
r = 26

'Copy Range from Excel
  Set rng = ThisWorkbook.ActiveSheet.Range("B2:Y25")

'This helps my macro loop through to repeat the build for multiple ppt slides
Restart:
Do Until i = 19


'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.ActivePresentation

'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(2, 11) '11 = ppLayoutTitleOnly


'Copy Excel Range
  rng.Offset(r * i, 0).Copy


'Paste to PowerPoint and position
 DoEvents
  mySlide.Shapes.PasteSpecial DataType:=0  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

'Set position:
  myShape.Left = 10
  myShape.Top = 45

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

'Clear The Clipboard
  Application.CutCopyMode = False

Dim myPic As Object
Dim NewWidth As Long
Dim NewHeight As Long

'Set Obj Variable equal to Current Selected Object
    On Error GoTo Select_Object
    Set myPic = myShape
    On Error GoTo 0

'Resize width and height
    myPic.Width = myPic.Width + 65
    myPic.Height = myPic.Height + 85

 i = i + 1

 GoTo Restart

Exit Sub

'Error Handler In Case No Object is Currently Selected
 Select_Object:
 MsgBox "No object selected to center."

 Loop

 End Sub

从Excel动态复制到多种格式的Powerpoint幻灯片

0 个答案: