VBA：Excel到Powerpoint复制+将选定图表粘贴到主动PPT幻灯片

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

因此，这里有一个适用于我的解决方案。宏复制+将选定的范围或图表粘贴到活动的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 

Answer 2

在Excel的图表中似乎没有一个简单的.IsSelected属性，因此您需要分析选择功能，您可以从过程中调用该功能来获取选定图表的集合（进行测试在处理集合中的每个商品之前，确保它不是Nothing）：

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