Question

我希望将Excel中的选定图表复制+粘贴到有效 PPT幻灯片中。我有一个代码，可以创建一个新的工作簿并粘贴工作簿中的所有图表，但希望将命令限制为只选择的图表。这是代码：

Option Explicit
Sub CopyChartsToPowerPoint()

'Excel Application objects declaration
Dim ws As Worksheet
Dim objChartObject As ChartObject
Dim objChart As Chart
Dim objCht As Chart
Dim lngSlideKount As Long

'Powerpoint Application objects declaration
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide

'Create a new Powerpoint session
Set pptApp = CreateObject("PowerPoint.Application")

pptApp.Visible = msoTrue
'Create a new presentation
Set pptPres = pptApp.Presentations.Add
Set pptPres = pptApp.ActivePresentation

pptApp.ActiveWindow.ViewType = ppViewSlide

lngSlideKount = 0
For Each ws In ActiveWorkbook.Worksheets
  'Verify if there is a chart object to transfer
  If ws.ChartObjects.Count > 0 Then
    For Each objChartObject In ws.ChartObjects
        Set objChart = objChartObject.Chart
        'ppLayoutBlank = 12
        Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
        pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex

    With objChart
        'Copy + paste chart object as picture
        objChart.CopyPicture xlScreen, xlBitmap, xlScreen
        pptSld.Shapes.Paste.Select
        'Coordinates will change depending on chart
        With pptApp.ActiveWindow.Selection.ShapeRange
            .Left = 456
            .Top = 20
        End With
    End With

      lngSlideKount = lngSlideKount + 1
    Next objChartObject
  End If
Next ws

' Now check CHART sheets:
For Each objCht In ActiveWorkbook.Charts
    'ppLayoutBlank = 12
    Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
    pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
    With objCht
        'Copy chart object as picture
        .CopyPicture xlScreen, xlBitmap, xlScreen
        'Paste copied chart picture into new slide
        pptSld.Shapes.Paste.Select
        pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    End With
    lngSlideKount = lngSlideKount + 1
Next objCht
'
'Activate PowerPoint application
pptApp.ActiveWindow.ViewType = ppViewNormal
pptApp.Visible = True
pptApp.Activate
If lngSlideKount > 0 Then
    If lngSlideKount = 1 Then
        MsgBox "1 chart was copied to PowerPoint", vbOKOnly + vbInformation, "Information"
    Else
        MsgBox lngSlideKount & " charts were copied to PowerPoint", vbOKOnly + vbInformation, "Information"
    End If
End If


End Sub

感谢大家的帮助！

Answer 1

在Excel for Charts中似乎没有一个很好的简单的.IsSelected属性，所以你需要分析选择，就像在这个函数中一样，你可以从你的程序调用来获取所选图表的集合（测试到在处理集合中的每个项目之前确保它不是什么都没有：

Option Explicit

' ***********************************************************
' Purpose:  Get a collection of selected chart objects.
' Inputs:   None.
' Outputs:  Returns a collection of selected charts.
' Author:   Jamie Garroch
' Company:  YOUpresent Ltd. http://youpresent.co.uk/
' ***********************************************************
Function GetSelectedCharts() As Collection
  Dim oShp As Shape
  Dim oChartObjects As Variant
  Set oChartObjects = New Collection

  ' If a single chart is selected, the returned type is ChartArea
  ' If multiple charts are selected, the returned type is DrawingObjects
  Select Case TypeName(Selection)
    Case "ChartArea"
      oChartObjects.Add ActiveChart
    Case "DrawingObjects"
      For Each oShp In Selection.ShapeRange
        If oShp.Type = msoChart Then
          Debug.Print oShp.Chart.Name
          oChartObjects.Add oShp.Chart
        End If
      Next
  End Select

  Set GetSelectedCharts = oChartObjects
  Set oChartObjects = Nothing
End Function

Answer 2

所以这是一个对我有用的解决方案。宏复制+将选定的范围或图表粘贴到活动的PowerPoint幻灯片中的某个位置。我想这样做的原因是每个季度/月我们都会为客户生成报告，这有助于减少复制+粘贴所需的时间并使甲板看起来更好。希望这可以帮助其他任何制作大量PPT的人！

'Export and position into Active Powerpoint

'Prior to running macro, enable Microsoft Powerpoint Object Library in Tools - Reference

'Identifies selection as either range or chart
Sub ButtonToPresentation()

If TypeName(Selection) = "Range" Then
    Call RangeToPresentation
Else
    Call ChartToPresentation
End If

End Sub

Sub RangeToPresentation()

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide

'Error message if range is not selected
If Not TypeName(Selection) = "Range" Then
    MsgBox "Please select a worksheet range and try again."
Else
    'Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    'Reference active presentation
    Set PPPres = PPApp.ActivePresentation
    'Reference active slide
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

    'Copy the range as a picture
    Selection.CopyPicture Appearance:=xlScreen, _
    Format:=xlBitmap
    'Paste the range
    PPSlide.Shapes.Paste.Select

    'Align the pasted range
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
End If

End Sub

Sub ChartToPresentation()
'Uses Late Binding to the PowerPoint Object Model
'No reference required to PowerPoint Object Library

Dim PPApp As Object 'As PowerPoint.Application
Dim PPPres As Object 'As PowerPoint.Presentation
Dim PPSlide As Object 'As PowerPoint.Slide

'Error message if chart is not selected
If ActiveChart Is Nothing Then
    MsgBox "Please select a chart and try again."
Else
    'Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    'Reference active presentation
    Set PPPres = PPApp.ActivePresentation
   'PPApp.ActiveWindow.ViewType = 1 ' 1 = ppViewSlide
    'Reference active slide
    Set PPSlide = PPPres.Slides _
        (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

    'Copy chart as a picture
    ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
        Format:=xlPicture
    'Paste chart
    PPSlide.Shapes.Paste.Select

    'Align pasted chart
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
End If

End Sub

VBA：Excel到Powerpoint复制+将所选图表粘贴到活动PPT幻灯片中

2 个答案: