在多张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

试试这个。 几点：

您不需要为每个图表/幻灯片等添加一个新变量。根据需要重复使用一个就足够了。

除非没有办法（在 Excel 或 PPT 中），否则切勿使用 SELECT。它使代码更加脆弱，并迫使您使应用程序可见（大多数时候并不是真正必要的）。由于 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