在多個PPT幻燈片上定位Excel多個圖表

Question

這是我第一次在這裏問一個問題，因爲你們和加爾斯是如此之好，以至於我從來沒有到過現在！

我有以下VBA代碼，它成功地從電子表格中拉出圖表，並將它們粘貼到兩個新創建的PPT幻燈片上。但唯一的問題是，此代碼只能將第二張幻燈片上的圖表對齊，而不會影響第一張幻燈片上的圖表。 我不能爲了我的生活找出她發生了什麼，並會非常感謝任何輸入！

Option Explicit 
Sub MakeSlides() 
Dim myData As Excel.Range 
Dim sheet2 As Excel.Worksheet 
Dim objPPT As Object 
Set sheet2 = ActiveWorkbook.Sheets("Sheet2") 
Set myData = sheet2.Range("A2:B43") 
Set objPPT = CreateObject("Powerpoint.application") 
myData.Copy 
Dim pptApp As New PowerPoint.Application 
pptApp.Visible = True 
Dim pres As PowerPoint.Presentation 
Set pres = pptApp.Presentations.Add 
Dim firstslide As PowerPoint.Slide 
Set firstslide = pres.Slides.Add(1, PowerPoint.PpSlideLayout.ppLayoutBlank) 
Dim myChart As Excel.ChartObject 
Set myChart = Sheet1.ChartObjects(1) 
myChart.Copy 
firstslide.Shapes.Paste.Select 
' Align pasted chart 
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True 
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True 
Set sheet2 = ActiveWorkbook.Sheets("Sheet2") 
Set myData = sheet2.Range("A45:B69") 
myData.Copy 
pptApp.Visible = True 
Dim secondslide As PowerPoint.Slide 
Set secondslide = pres.Slides.Add(1, PowerPoint.PpSlideLayout.ppLayoutBlank) 
Set myChart = Sheet1.ChartObjects(2) 
myChart.Copy 
secondslide.Shapes.Paste 
' Align pasted chart 
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True 
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True 

結束子

Answer 1

也許這樣;將圖表粘貼到第一張幻燈片上後立即對齊：

Option Explicit 
Sub MakeSlides() 
[...] 
    myChart.Copy 
    firstslide.Shapes.Paste.Select 
    ' Align pasted chart 
    pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True 
    pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True 

    Set sheet2 = ActiveWorkbook.Sheets("Sheet2") 
    Set myData = sheet2.Range("A45:B69") 
    myData.Copy 
    pptApp.Visible = True 
    Dim secondslide As PowerPoint.Slide 
    Set secondslide = pres.Slides.Add(1, PowerPoint.PpSlideLayout.ppLayoutBlank) 
    Set myChart = Sheet1.ChartObjects(2) 
    myChart.Copy 
    secondslide.Shapes.Paste 
    ' Align pasted chart 
    pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True 
    pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True 
End Sub 

Answer 2

請嘗試此操作。 幾點：

你不需要爲每個圖表/幻燈片等一個新的變量。一個，需要重用，是很多。

不要使用SELECT，除非沒有辦法繞過它（在Excel或PPT中）。它使代碼更加脆弱，迫使你使應用程序可見（大部分時間不是必需的）。由於PPT必須重繪所有內容，因此它也會使您的代碼減慢一個數量級。

Sub MakeSlides() 
Dim myData As Excel.Range 
Dim sheet2 As Excel.Worksheet 
Dim objPPT As Object 
Set sheet2 = ActiveWorkbook.Sheets("Sheet2") 
Set myData = sheet2.Range("A2:B43") 
Set objPPT = CreateObject("Powerpoint.application") 
myData.Copy 
Dim pptApp As New PowerPoint.Application 
pptApp.Visible = True 
Dim pres As PowerPoint.Presentation 
Set pres = pptApp.Presentations.Add 
Dim oSlide As PowerPoint.Slide 
Dim oChtShape as PowerPoint.Shape 

Set oSlide = pres.Slides.Add(1, PowerPoint.PpSlideLayout.ppLayoutBlank) 
Dim myChart As Excel.ChartObject 
Set myChart = Sheet1.ChartObjects(1) 
myChart.Copy 
Set oChtShape = oSlide.Shapes.Paste(1) 

' Align pasted chart 
oChtShape.Align msoAlignCenters, True 
oChtShape.Align msoAlignMiddles, True 

' Not sure what this is supposed to do: 
Set sheet2 = ActiveWorkbook.Sheets("Sheet2") 
Set myData = sheet2.Range("A45:B69") 
myData.Copy 

' it's already visible; don't need this 
'pptApp.Visible = True 

' don't need a new object variable for each slide; 
' reuse the existing variable instead 
Set oSlide = pres.Slides.Add(1, PowerPoint.PpSlideLayout.ppLayoutBlank) 
Set myChart = Sheet1.ChartObjects(2) 
myChart.Copy 

'secondslide.Shapes.Paste 
Set oChtShape = oSlide.Shapes.Paste(1) 

' Align pasted chart 
oChtShape.Align msoAlignCenters, True 
oChtShape.Align msoAlignMiddles, True 

End Sub