将图表和表格从Excel工作表复制到现有的PowerPoint幻灯片2

Question

我正在尝试将一张表和图表从一个工作表“ Account Performance”复制到现有的PowerPoint幻灯片中。 2下面提到的代码中存在三个问题：第一个问题，我编写了两个代码，一个用于复制表（通过指定范围），另一个用于复制图表，但是当我运行代码时，该表被粘贴在幻灯片上两次并且不粘贴图表。 我做错了什么？ 第二个问题，为chartobject设置的位置代码给了错误第三个问题，在大多数情况下，代码没有给出错误，但有时代码在下面提到的行上给出了错误：pres.Slides（2）.Shapes.Paste

请在下面的代码中找到：

Sub latestppu()
  Dim pptapp As PowerPoint.Application
  Dim pres As PowerPoint.Presentation
  Dim preslide As PowerPoint.Slide
  Dim shapepp As PowerPoint.Shape
  Dim exappli As Excel.Application
  Dim exworkb As Workbook
  Dim rng As Range
  Dim myshape As Object
  Dim x As Integer

  x = 1

  Dim mychart As ChartObject
  Dim activechart As ChartObject
  Dim R As Integer
  Dim G As Integer
  Dim B As Integer

  'Open powerpoint application -
  Set exappli = New Excel.Application
  exappli.Visible = True

  'activate powerpoint application
  Set pptapp = New PowerPoint.Application

  pptapp.Visible = True
  pptapp.Activate

  'open the excel you wish to use

  Set exworkb = exappli.Workbooks.Open("C:\Users\astha.verma\Desktop\Macro\Reference Sheet.xlsm")


  'open the presentation you wish to use
  Set pres = pptapp.Presentations.Open("C:\Users\astha.verma\Desktop\Macro\PPTtemplate.pptx")

  'Add title to the first slide
  With pres.Slides(1)

    If Not .Shapes.HasTitle Then
       Set shapepp = .Shapes.AddTitle
    Else:
       Set shapepp = .Shapes.Title
    End If

    With shapepp
      .TextFrame.TextRange.Text = "Gulf+ Market Segment Analysis Report" & vbNewLine & "P5 Week 04 FY17"
      .TextFrame.TextRange.Font.Name = "Arial Black"
      .TextFrame.TextRange.Font.Size = 24
      .TextEffect.FontBold = msoTrue
      .TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
    End With
  End With

  'Add title to second slide
  With pres.Slides(2)
    If Not .Shapes.HasTitle Then
       Set shapepp = .Shapes.AddTitle
    Else:
       Set shapepp = .Shapes.Title
    End If

    With shapepp
      .TextFrame.TextRange.Text = "Gulf+ Account Performance"
      .TextFrame.TextRange.Font.Name = "EY Gothic Cond Demi"
      .TextFrame.TextRange.Font.Size = 22
      .TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
      .TextEffect.FontBold = msoFalse
      .TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
      .TextEffect.Alignment = msoTextEffectAlignmentLeft
    End With
  End With

  'add a textbox

  Set shapepp = pres.Slides(2).Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=650, Top:=75, Width:=200, Height:=50)

  With shapepp
    .TextFrame.TextRange.Text = "Other Account Performance Metrics"
    .TextFrame.TextRange.Font.Name = "EY Gothic Cond Demi"
    .TextFrame.TextRange.Font.Size = 16
    .TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignRight
    .TextEffect.FontBold = msoTrue
    .TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
  End With

  'Copy a table range from account summary worksheet and paste it in powerpoint slide 2:-

  'defining the range
  Set rng = exworkb.Sheets("Account Performance").Range("A1:B5")

  'Copy excel range
  rng.Copy

  'paste to powerpoint slide 2
  '**attimes gives error on this line(did I do anything wrong)**
  pres.Slides(2).Shapes.Paste

  pptapp.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, msoTrue
  pptapp.ActiveWindow.Selection.ShapeRange.Top = -30
  pptapp.ActiveWindow.Selection.ShapeRange.Left = 350

  On Error Resume Next

  'add a textbox

  Set shapepp = pres.Slides(2).Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=600, Top:=280, Width:=200, Height:=50)

  With shapepp
    .TextFrame.TextRange.Text = "GTER by global account segment"
    .TextFrame.TextRange.Font.Name = "EY Gothic Cond Demi"
    .TextFrame.TextRange.Font.Size = 16
    .TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignRight
    .TextEffect.FontBold = msoTrue
    .TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
  End With

  'defining the second  chart to be copied
  Set mychart = exworkb.Sheets("Account Performance").ChartObjects

  'Copy first chart
  mychart.Chart.ChartObjects.Copy

  'paste to powerpoint slide 2
  pres.Slides(2).Shapes.Paste

  'position?
  With pres.Slides(2).Shapes(1)
    .Top = 165
    .Left = 200
  End With

End Sub

Answer 1

On Error Resume Next的问题在于，它不仅有助于绕过您可能期望的错误，而且还绕过使代码不起作用的错误。

我不知道下面的前两个命令是做什么的，但是我认为它们充满了您不知道的错误（由于Resume Next ），因此什么也不会被复制。 剪贴板仍然包含表格，这就是要粘贴的内容。

'defining the second  chart to be copied
Set mychart = exworkb.Sheets("Account Performance").ChartObjects

'Copy first chart
mychart.Chart.ChartObjects.Copy

'paste to powerpoint slide 2
pres.Slides(2).Shapes.Paste

那么，为什么要谈论第一张和第二张图表呢？

您应该将变量mychart声明为图表，然后将其正确分配为图表（是“帐户效果”上的哪个图表？我假设为1），然后正确地进行复制。

'define the chart to be copied
Set mychart = exworkb.Sheets("Account Performance").ChartObjects(1).Chart

'copy the chart
mychart.ChartArea.Copy

' inserted to help with timing errors
DoEvents

'paste to powerpoint slide 2
pres.Slides(2).Shapes.Paste