VBA：從Excel復制+粘貼所選圖表到Powerpoint

Question

我希望將選定的圖表從Excel 2010復制並粘貼為Powerpoint 2010，並將它們作為Microsoft Excel圖表對象格式粘貼到活動的 PPT幻燈片中。 理想情況下，我希望能夠將這些圖表放置在活動的Powerpoint幻燈片上的特定位置。 我搜尋了網絡，但即使不是大多數解決方案，所有解決方案都是將工作表中的所有幻燈片隨機粘貼到PPT幻燈片上。 我什至沒有代碼，但是如果有人可以提供幫助，那將非常棒。 謝謝！

Answer 1

好吧，這是東西：這是我以前寫的pptGenerator類。 在我的場景中，我想右鍵單擊工作簿中的特定圖表，在自定義上下文菜單中將“復制到演示文稿”作為選項，然后在同一演示文稿或新演示文稿的后續幻燈片中添加后續圖表。 這些圖表是在另一個類中捕獲的，以便創建上下文菜單，並在傳遞給幻燈片時將其自身復制到幻燈片。 下面是經過稍微修改和剝離的版本，該版本應該可以幫助您通過編輯此類來解決您的特定情況。

在類模塊中：

'PowerPoint Generator class - Rik Sportel
'Maintains a PowerPoint application for Excel workbook.
Private WithEvents pptApp As PowerPoint.Application
Private ppt As PowerPoint.Presentation
Private pptPresentations As Collection 'Collection to add presentations to
Private p_currentPresentation As Boolean

'Make sure you don't add slides if there is no presentation.
Public Property Get CurrentPresentation() As Boolean
    CurrentPresentation = p_currentPresentation
End Property

'Initialization
Private Sub Class_Initialize()
    p_currentPresentation = False
    Set pptApp = New PowerPoint.Application
    Set pptPresentations = New Collection
End Sub

'Termination
Private Sub Class_Terminate()
    Set pptPresentations = Nothing
    Set pptApp = Nothing
End Sub

'Creates a new Presentation in the powerpoint app, and adds it to the pptPresentations collection. Add methods later to cycle through them.
Public Sub NewPresentation()
    Set ppt = pptApp.Presentations.Add
    pptPresentations.Add ppt

    'Create presentation and use image stored within the current workbook as a background for it.
    ThisWorkbook.Worksheets("BGItems").Shapes(1).Copy 'Copy the background
    ppt.Windows(1).ViewType = ppViewSlideMaster
    ppt.Windows(1).View.Paste 'Paste the background
    ppt.Windows(1).ViewType = ppViewNormal

    p_currentPresentation = True
End Sub

'Add a slide to the presentation, place passed chart on it.
Public Sub AddSlide(chartForSlide As Chart)
    Dim nSlide As PowerPoint.Slide
    Dim nChart As PowerPoint.Shape

    'Create a new slide with the chart on it.
    Set nSlide = pptApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)

    chartForSlide.ChartArea.Copy
    nSlide.Shapes.Paste 'Paste the chart
    Set nChart = nSlide.Shapes(1)

    'Position the chart
    With nChart
        .Left = ppt.PageSetup.SlideWidth / 10
        .top = ppt.PageSetup.SlideHeight / 10
        .Width = ppt.PageSetup.SlideWidth / 100 * 80
        .Height = ppt.PageSetup.SlideHeight / 2
    End With

    Set nChart = Nothing
    Set nSlide = Nothing
End Sub

'Make sure to keep track of presentations properly if users interact with
'powerpoint in unexpected ways. Capture event and make sure the presentation object you write to will still exist.
Private Sub pptApp_PresentationClose(ByVal Pres As PowerPoint.Presentation)
    For i = pptPresentations.Count To 1 Step -1
        If pptPresentations.Item(i) Is Pres Then
            pptPresentations.Remove i
        End If
    Next i
    If Pres Is ppt Then
        Set ppt = Nothing
        p_currentPresentation = False
    End If
End Sub

在我的“工廠”模塊中。 常規代碼模塊：

Public Sub GetPowerpoint()
    If pptApp Is Nothing Then Set pptApp = New pptGenerator
End Sub

使用方法：

'Pass a chart + optionally if it has to be a new presentation:
Public Sub CopyChartToPpt(tChart As Chart, Optional newPres As Boolean)
    GetPowerpoint
    If pptApp.CurrentPresentation = False Then pptApp.NewPresentation
    If newPres = True Then pptApp.NewPresentation

    pptApp.AddSlide tChart 

End Sub

因此，從何處以及如何獲得所選圖表是另一回事，但是，只要您設法從工作簿的ChartObject或Slide中選擇圖表，並將其作為參數傳遞給上面，您應該能夠根據以下內容進行修復根據您自己的規格。

除了我的建議外，請在MSDN上檢查您的Powerpoint版本的VBA參考。

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