Question

我有一个带有Macro的Excel，该Excel应该：切换到有效的PPT 选择幻灯片“ X”并删除图表转到Excel中的“ X”标签抓新图粘贴到“ X”幻灯片上重复5次

这是我到目前为止编译的代码：

Dim PPT As Object
Dim rng As Object
Dim rng1 As Object
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim ActivePresentation As Object


'Copy Range from Excel
  Set rng = Sheet3.ChartObjects("Chart 6")
Set rng1 = Sheet3.ChartObjects("Chart 7")
Set rng2 = Sheet3.ChartObjects("Chart 8")

Set PPT = CreateObject("PowerPoint.Application")

With PPT
.Visible = True
.WindowState = 1
.Activate
End With
'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")


Set myPresentation = PowerPointApp.Presentations.Add *this should not say add as it adds a slide,but no luck with any other commands*
' PowerPointApp.Presentations.Add
Set mySlide = myPresentation.Slides.Add(1, 11) *this should not say add as it adds a slide,but no luck with any other commands*
'Copy Excel Range
  rng.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

    'Set position:
      myShape.Left = 20
      myShape.Top = 152

rng1.Copy
mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  myShape.Left = 486
      myShape.Top = 152

      Set mySlide = myPresentation.Slides.Add(2, 11) '11 = ppLayoutTitleOnly

     etc..


End Sub

这创建了一个新的PPT并将幻灯片添加到新的ppt中，尝试了许多帮助和网页，但不幸的是，它找不到能够解决该问题的代码。如果您能为我提供建议或指向正确的帮助或教程，将可以解决此问题。

Answer 1

代码基于您的陈述中的以下假设

已经打开了演示文稿
要从每张纸复制两个或三个图表，分别从Sheets（2）到Sheets（5）到幻灯片2至5，如下所示。

代码可能会根据您的要求进行修改

Sub AddtoOpenPPT()
Dim PPT As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShape As PowerPoint.Shape
Dim Fname As String
Dim sld As Long, i As Long, ObjNo As Long
Dim Rng(0 To 9)  As Object

Set Rng(0) = Sheet3.ChartObjects("Chart 6")
Set Rng(1) = Sheet3.ChartObjects("Chart 7")
Set Rng(2) = Sheet3.ChartObjects("Chart 8")
Set Rng(3) = Sheet3.ChartObjects("Chart 5")
Set Rng(4) = Sheet1.Range("b4:j14")
Set Rng(5) = Sheet1.Range("A4:l4", "A15:j19")
Set Rng(6) = Sheet4.ChartObjects("Chart 13")
Set Rng(7) = Sheet4.ChartObjects("Chart 15")
Set Rng(8) = Sheet4.ChartObjects("Chart 17")
Set Rng(9) = Sheet4.ChartObjects("Chart 19")


Set PPT = GetObject(class:="PowerPoint.Application")
Set myPresentation = PPT.ActivePresentation
    ObjNo = 0
    For sld = 2 To 5
    Set mySlide = myPresentation.Slides(sld)

            For i = mySlide.Shapes.Count To 1 Step -1
            mySlide.Shapes(i).Delete
            Next

            For i = 1 To 3
            Rng(ObjNo).Copy
            mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
            Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
            myShape.Left = IIf(i Mod 2 = 1, 20, 486)
            myShape.Top = IIf(i < 3, 50, 200)
            ObjNo = ObjNo + 1
            If ObjNo > UBound(Rng) Then Exit For
            Next
    If ObjNo > UBound(Rng) Then Exit For
    Next sld
    End Sub

如何通过VBA选择特定的幻灯片

1 个答案: