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

End Sub

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

在多个PPT幻灯片上定位Excel多个图表

2 个答案: