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