excel图表到powerpoint vba

我有一个标准代码，可以将活动工作表中的所有图表打印到新的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改为整个工作簿，以便复制工作簿中的所有图表。我尝试介绍我用来阅读工作簿和删除所有工作表的内容：

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

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

---

谢谢

导出图表之前，您必须激活工作表。我以前在导出图表时遇到过这个问题

试试这个

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

---

导出图表之前，必须激活工作表。我以前在导出图表时遇到过这个问题

试试这个

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

---

`子选定的图纸电源点（）

`

---

它运行并输出所有图形，但它不会停止，它只会继续复制并循环所有工作表，直到在复制了大约15次后我将其关闭。

`Sub-SelectedSheetsPowerPoint（）

`

---

它运行并输出所有图形，但它不会停止，它只会继续复制并循环所有图纸，直到我在复制了大约15次后将其关闭。

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

我正在尝试做类似的事情，看看上面的代码，每个循环有3个，但我认为应该只有2个。一个循环工作表，另一个循环工作表中的每个图表。

嘿，siddarth，再次感谢您的快速回复，这是用于我上面的代码还是？当我试着用我现有的东西输入它们时，它只会复制出一张纸，它只会打开powerpoint，而不会复制它们？@Siddarth Rout抱歉，Siddarth我已经完全忘记了这一点，我的目标已经改变了，我需要上面使用的代码将当前工作表上的所有图表打印到powerpoint，以表示我需要工作表上的所有图表（“Sheet1”）、（“Sheet2”）、（Sheet3”）对于同一个PowerPoint，上面的循环仍然有效：）只需复制图表并粘贴到PP.@Siddarth Rout我将上面的代码发布在一个新的答案中，它出现了一个小问题，它会不断循环，不会停止循环，有什么想法吗？嘿，Siddarth，再次感谢你的快速回复，这是为了与我上面的代码一起工作还是s我试着用我现有的东西输入它们，目前只复制了一张纸，但它只是打开了powerpoint，没有复制它们？@Siddarth Rout对不起Siddarth我完全忘记了这一点，我的目标已经改变了，我需要上面使用的代码，将当前纸上的所有图表打印到powerpoint上，告诉他们我想要所有图表都在s上将表格（“Sheet1”）、（“Sheet2”）、（Sheet3”）粘贴到同一个PowerPoint上面的循环仍然有效：）只需复制图表并粘贴到第页。@Siddarth Rout我在新的答案中发布了上面的代码，但出现了一个小问题，它会不断循环，并且不会停止循环，有什么想法吗？@Siddarth Rout-使用上述布局，它不停地在所有页面上循环，我能做些什么让它只看一次每张图纸图表？@Siddarth Rout-按照上述布局，它不停地在所有页面上循环，我能做些什么让它只看一次每张图纸图表？