將圖表和表格從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