Question

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

我还没有找到任何方法以编程方式从VBA访问“智能标记”。此外，Paste Special选项似乎没有选项。

我正在使用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

这可能是非常糟糕的形式（在我的问题中回答Joel在他的回答中提出的问题的答案），但下面的代码可以帮助你解决你的问题Joel。这旨在从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

使用VBA将Excel图表复制到包含嵌入数据的PowerPoint

2 个答案: