使用VBA将数据从Excel复制到Powerpoint

Question

我用vba创建了一个代码，该代码可以从excel工作表中复制数据，并将其粘贴到与PowerPoint幻灯片中的图片相同的位置，但是它不能完全按照我的需要工作。

它应该从每个工作表中复制数据，然后将其明智地粘贴到给定的PowerPoint幻灯片工作表中。 Measn工作表1的数据应先复制到幻灯片1中，然后再复制工作表2的数据在幻灯片2中，依此类推，最后应保存创建的ppt文件。

但是我的代码是复制和粘贴Powerpoint幻灯片中彼此重叠的所有工作表数据。

由于我是vba的新手，所以我不确定下面的代码在哪里出问题：

Sub WorkbooktoPowerPoint()


Dim xlwksht As Worksheet
Dim MyRange As String
Dim MyRange1 As String 'Define another Range
Dim MyTitle As String
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Dim oSlide As Slide


Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
strPresPath = "C:\Users\FYI\PPT1.pptx"
strNewPresPath = "C:\Users\FYI\new1.pptx"

Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)

For Each oSlide In oPPTFile.Slides
i = oSlide.SlideNumber
oSlide.Select

MyRange = "B2:B5"
MyRange1 = "B8:B11"

For Each xlwksht In ActiveWorkbook.Worksheets
xlwksht.Select Application.Wait(Now + TimeValue("0:00:1"))

xlwksht.Range(MyRange).CopyPicture Appearance:=xlScreen, Format:=xlPicture


oSlide.Shapes.Paste.Select
oPPTApp.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, True
oPPTApp.ActiveWindow.Selection.ShapeRange.Top = 65
oPPTApp.ActiveWindow.Selection.ShapeRange.Left = 7.2
oPPTApp.ActiveWindow.Selection.ShapeRange.Width = 400

xlwksht.Range(MyRange1).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
oPPTApp.ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, True

oPPTApp.ActiveWindow.Selection.ShapeRange.Top = 250
oPPTApp.ActiveWindow.Selection.ShapeRange.Left = 7.2
oPPTApp.ActiveWindow.Selection.ShapeRange.Width = 400

Next xlwksht
Next


oPPTApp.Activate

oPPTFile.SaveAs strNewPresPath
oPPTFile.Close
oPPTApp.Quit

Set oPPTShape = Nothing
Set oPPTFile = Nothing
Set oPPTApp = Nothing
MsgBox "Presentation Created", vbOKOnly + vbInformation


End Sub

Answer 1

请试一下。 主要变化是我删除了For Each循环。 您已经在甲板上的幻灯片中循环浏览，并且可以使用幻灯片编号来引用Excel工作表（它们也已编号）。 它正在制造一团糟，现在运行平稳。

Sub WorkbooktoPowerPoint()
    Dim xlwksht As Worksheet
    Dim MyRange As String
    Dim MyRange1 As String 'Define another Range
    Dim oPPTApp As PowerPoint.Application
    Dim oPPTShape As PowerPoint.Shape
    Dim oPPTFile As PowerPoint.Presentation
    Dim SlideNum As Integer
    Dim oSlide As Slide
    Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
    strPresPath = "C:\Users\FYI\PPT1.pptx"
    strNewPresPath = "C:\Users\FYI\new1.pptx"

    Set oPPTApp = CreateObject("PowerPoint.Application")
    oPPTApp.Visible = msoTrue
    Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)

    For Each oSlide In oPPTFile.Slides
        i = oSlide.SlideNumber
        ' The following line was added after the OPs follow-up
        If i > ActiveWorkbook.Sheets.Count Then Exit For
        oSlide.Select

        MyRange = "B2:B5"
        MyRange1 = "B8:B11"

        With ActiveWorkbook.Sheets(i)
            .Range(MyRange).CopyPicture Appearance:=xlScreen, Format:=xlPicture
            oSlide.Shapes.Paste.Select
            With oPPTApp
                .ActiveWindow.Selection.ShapeRange.Align msoAlignTops, True
                .ActiveWindow.Selection.ShapeRange.Top = 65
                .ActiveWindow.Selection.ShapeRange.Left = 7.2
                .ActiveWindow.Selection.ShapeRange.Width = 400
            End With
            .Range(MyRange1).CopyPicture Appearance:=xlScreen, Format:=xlPicture
            oSlide.Shapes.Paste.Select
            With oPPTApp
                .ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, True
                .ActiveWindow.Selection.ShapeRange.Top = 250
                .ActiveWindow.Selection.ShapeRange.Left = 7.2
                .ActiveWindow.Selection.ShapeRange.Width = 400
            End With
        End With
    Next

    oPPTApp.Activate
    oPPTFile.SaveAs strNewPresPath
    oPPTFile.Close
    oPPTApp.Quit

    Set oPPTShape = Nothing
    Set oPPTFile = Nothing
    Set oPPTApp = Nothing
    MsgBox "Presentation Created", vbOKOnly + vbInformation
End Sub