Question

我有一个宏，我在这里找到，在Excel中为活动电子表格中的每个图表创建一个新的powerpoint幻灯片。我的问题是，我是否可以在带有宏的单个powerpoint幻灯片中复制两个或更多图表？

感谢您的帮助！

Answer 1

我使用的是我的宏代码。

Sub pruebaPPT()
    'Variables a usar
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject

On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0

'Creamos un nuevo ppt
If newPowerPoint Is Nothing Then
    Set newPowerPoint = New PowerPoint.Application
End If

'Creamos una presentación de ppt
If newPowerPoint.Presentations.Count = 0 Then
    newPowerPoint.Presentations.Add
End If

newPowerPoint.Visible = True 'Hacemos visible el ppt

'Bucle a través de cada char en las excel sheets para copiarlas en el ppt
For Each cht In ActiveSheet.ChartObjects
    'Añade una nueva slide donde copiará la char
    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)

    'Copia la char y la pega en el ppt como Metafile picture
    cht.Select
        ActiveChart.ChartArea.Copy
        'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select-->copia el grafica como formato de imagen
        activeSlide.Shapes.Paste.Select 'copia la chart como formato chart

    'Establece el nombre de la slide con el mismo nombre de la char de excel
    activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

    'Ajusta la posicion de la chart en la slide del ppt
    newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 350
    newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 220
    newPowerPoint.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    newPowerPoint.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True



    activeSlide.Shapes(2).Delete
    'activeSlide.Shapes(2).Left = 505

    Next

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

如何将两个或多个图表从excel复制到带有宏的powepoint幻灯片

1 个答案: