Excel图表到PowerPoint VBA

Question

我有一个标准代码，可将活动工作表中的所有图表打印到新的PowerPoint应用程序中：

Sub CreatePowerPoint()

'First we declare the variables we will be using
    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject

 'Look for existing instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

'Let's create a new PowerPoint
    If newPowerPoint Is Nothing Then
        Set newPowerPoint = New PowerPoint.Application
    End If
'Make a presentation in PowerPoint
    If newPowerPoint.Presentations.Count = 0 Then
        newPowerPoint.Presentations.Add
    End If

'Show the PowerPoint
    newPowerPoint.Visible = True

'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
    For Each cht In ActiveSheet.ChartObjects

    'Add a new slide where we will paste the chart
        newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
        newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

    'Copy the chart and paste it into the PowerPoint as a Metafile Picture
        cht.Select
        ActiveChart.ChartArea.Copy
        activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select

    'Set the title of the slide the same as the title of the chart
        activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

    'Adjust the positioning of the Chart on Powerpoint Slide
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125

        activeSlide.Shapes(2).Width = 200
        activeSlide.Shapes(2).Left = 505

    Next

AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing

End Sub

我需要做的是将Activesheet而不是Activesheet更改为整个工作簿，因此请复制工作簿中的所有图表。 我尝试介绍我用来通读工作簿并删除所有工作表的内容：

Sub ClearCharts()

Dim wsItem As Worksheet
Dim chtObj As ChartObject

For Each wsItem In ThisWorkbook.Worksheets

    For Each chtObj In wsItem.ChartObjects

        chtObj.Delete

    Next

Next

End Sub

但是当我尝试编辑活动表行时，它会运行并且不会复制图表。 任何想法，我将不胜感激。

谢谢

Answer 1

我现在正在尝试做类似的事情，查看上面的代码，您有3个For Each循环，但我相信您应该只有2个。 一个循环在工作表上，第二个循环在工作表中的每个图表上。

Answer 2

`Sub SelectedSheetsPowerPoint（）

Dim wsItem As Worksheet
Dim chtObj As ChartObject
For Each wsItem In ThisWorkbook.Worksheets
For Each chtObj In wsItem.ChartObjects
wsItem.Activate
'~~> Code here to copy it to the poerpoint
'~~> Same for deleting it


'First we declare the variables we will be using
    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject

 'Look for existing instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

'Let's create a new PowerPoint
    If newPowerPoint Is Nothing Then
        Set newPowerPoint = New PowerPoint.Application
    End If
'Make a presentation in PowerPoint
    If newPowerPoint.Presentations.count = 0 Then
        newPowerPoint.Presentations.Add
    End If

'Show the PowerPoint
    newPowerPoint.Visible = True

'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
    For Each cht In ActiveSheet.ChartObjects

    'Add a new slide where we will paste the chart
        newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.count + 1, ppLayoutText
        newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.count)

    'Copy the chart and paste it into the PowerPoint as a Metafile Picture
        cht.Select
        ActiveChart.ChartArea.Copy
        activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select

    'Set the title of the slide the same as the title of the chart
        activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

    'Adjust the positioning of the Chart on Powerpoint Slide
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 75
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 120

        activeSlide.Shapes(2).Width = 200
        activeSlide.Shapes(2).Left = 505
     'loop through each chart in !!activesheet!! and move each into a new slide!
    Next
'start pp, can add preset headings for power point here
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing

DoEvents

Next
Next

End Sub

`

它运行并显示所有图形，但不会停止，它将一直复制并循环遍历所有工作表，直到将其复制大约15次后我将其关闭。

Answer 3

在导出图表之前，您必须先激活工作表。 过去在导出图表时我曾遇到过此问题。

尝试这个

Dim wsItem As Worksheet
Dim chtObj As ChartObject

For Each wsItem In ThisWorkbook.Worksheets
    For Each chtObj In wsItem.ChartObjects

        wsItem.Activate

        '~~> Code here to copy it to the poerpoint
        '~~> Same for deleting it

        DoEvents

    Next
Next