使用VBA将Excel图表复制到带有嵌入式数据的PowerPoint

Question

从Excel中粘贴图表后，在图表的右下方弹出一个“智能标记”，从中可以选择“ Excel图表（整个工作簿）”（与默认的“图表”（链接到Excel）相对数据）”）。 这具有将数据嵌入图表中的效果，以便仍可以修改数据，但图表未链接到Excel文件。 有没有人能够使用VBA（在Excel-VBA或PowerPoint-VBA中使用）复制此内容？

我还没有找到通过VBA以编程方式访问“智能标记”的任何方法。 此外，“选择性粘贴”选项似乎对此没有选项。

我正在使用Office 2007。

Answer 1

试试这个Tahlor：

Option Explicit

' ===========================================================================================
' Copy Specified chart to PowerPoint whilst maintaining a data link.
' Written by : Jamie Garroch of YOUpresent Ltd. (UK)
' Date : 08 JULY 2015
' For more amazing PowerPoint stuff visit us at from http://youpresent.co.uk/
' ===========================================================================================
' Copyright (c) 2015 YOUpresent Ltd.
' Source code is provide under Creative Commons Attribution License
' This means you must give credit for our original creation in the following form:
' "Includes code created by YOUpresent Ltd. (YOUpresent.co.uk)"
' Commons Deed @ http://creativecommons.org/licenses/by/3.0/
' License Legal @ http://creativecommons.org/licenses/by/3.0/legalcode
' ===========================================================================================
' Macro Execution Environment : Designed to run in Excel VBA.
' ===========================================================================================
' You can use Early Binding (with the advantage that IntelliSense adds) by adding a reference
' to the PowerPoint Object Library and setting the compiler constant EARLYBINDING to True
' but delete it afterwards otherwise you will face a nightmare of compatibility!!!
' ===========================================================================================

#Const EARLYBINDING = False

Sub CopyPasteLinkedChartToPowerPoint()
#If EARLYBINDING Then
  ' Define Early Binding PowerPoint objects so you can use IntelliSense while debuggging
  ' Requires a reference (Tools/References) to the Microsoft PowerPoint XX.Y Object Library
  Dim oPPT As PowerPoint.Application
  Dim oPres As PowerPoint.Presentation
  Dim oSld As PowerPoint.Slide
#Else
  ' Define Late Binding PowerPoint objects
  ' Remove the reference to the Microsoft PowerPoint Object Library
  Dim oPPT As Object
  Dim oPres As Object
  Dim oSld As Object
  Const ppLayoutTitle = 1
#End If
  ' Define Excel objects
  Dim oWB As Workbook
  Dim oWS As Worksheet
  Dim oCHT As ChartObject

  Set oPPT = CreateObject("PowerPoint.Application")
  Set oPres = oPPT.Presentations.Add(msoTrue)
  Set oSld = oPres.Slides.Add(1, ppLayoutTitle)

  ' Modify these lines according to how you want to selet the chart
  Set oWB = ActiveWorkbook
  Set oWS = oWB.Worksheets(1)
  Set oCHT = oWS.ChartObjects(1)
  oCHT.Select
  ActiveChart.ChartArea.Copy

  ' Paste the chart to the PowerPoint slide with a data link
  oSld.Shapes.PasteSpecial link:=msoTrue

  ' Clear objects
  Set oPPT = Nothing: Set oPres = Nothing: Set oSld = Nothing
  Set oWB = Nothing: Set oWS = Nothing: Set oCHT = Nothing
End Sub

Answer 2

这可能是一种非常糟糕的形式（将我的问题的答案张贴在他的答案中作为乔尔问题的答案），但是下面的代码应该可以帮助您解决乔尔的问题。 它旨在从PowerPoint中运行，并且将删除所选图表不使用的所有工作表。 将其移植到Excel应该非常简单，只需确保chart1是您刚刚粘贴的PowerPoint图表，而不是您复制过来的Excel图表即可。 无论如何，要格外小心，以确保将图形粘贴到数据中（而不是链接到原始工作簿），因为此代码将删除图表引用的任何工作簿中的所有多余工作表。

这尚未经过彻底测试。 显然，备份所有内容。

'Delete extra sheets of selected chart in PowerPoint
Sub delete_excess_sheets()
Application.DisplayAlerts = False
Dim chart1 As Chart, used_sheets As Collection
Set chart1 = ActiveWindow.Selection.ShapeRange(1).Chart
chart1.ChartData.Activate
chart1.ChartData.Workbook.Application.DisplayAlerts = False

'Get sheets being used by chart
Set used_sheets = find_source(chart1)

For Each sht In chart1.ChartData.Workbook.worksheets 'this only loops through worksheets, not worksheet-charts
'note that you might first copy/paste values of the sheet supporting the data, if that sheet itself refers to other sheets
    If Not InCollection(used_sheets, sht.Name) Then
        sht.Delete
    End If
Next

Application.DisplayAlerts = True
chart1.ChartData.Workbook.Application.DisplayAlerts = True

End Sub

'Determine which sheets are being used by the chart
Function find_source(search_cht As Object) As Collection

Dim strTemp As String, sheet_collection As New Collection
For Each mysrs In search_cht.SeriesCollection
    first_part = Split(Split(mysrs.Formula, "!")(0), "=SERIES(")(1)
    If (InStr(first_part, "'") = 1 And Right(first_part, 1) = "'") Then first_part = Mid(first_part, 2, Len(first_part) - 2)
    sheet_collection.Add first_part, first_part
Next
Set find_source = sheet_collection

End Function

'Determine if object is in a collection
Public Function InCollection(col As Collection, key As String) As Boolean
  Dim var As Variant
  Dim errNumber As Long

  InCollection = False
  Set var = Nothing

  err.Clear
  On Error Resume Next
    var = col.Item(key)
    errNumber = CLng(err.Number)
  On Error GoTo 0

  '5 is not in, 0 and 438 represent incollection
  If errNumber = 5 Then ' it is 5 if not in collection
    InCollection = False
  Else
    InCollection = True
  End If

End Function