如何將兩個或多個圖表從宏複製到宏點的宏點幻燈片

Question

我有一個宏，我在這裏找到Excel，它爲活動電子表格中的每個圖表創建一個新的幻燈片。我的問題是，如果我可以在一個幻燈片中使用宏複製兩個或多個圖表？

感謝您的幫助！

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