使用vba将数据从Excel复制到powerpoint

我用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

---

请试一试。主要的变化是我删除了每个循环的

。您已经在幻灯片组中循环浏览幻灯片，可以使用幻灯片编号引用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

粘贴第二张工作表之前，既不创建第二张幻灯片，也不选择另一张幻灯片。在下一个xlwksht

之前，请尝试

.AddSlide

方法。嗨，我没有得到确切的地方，我需要改变代码来完成它。你能告诉我一些细节吗。这将是一个很大的帮助！忘了我说的吧。显然你已经有了所有的幻灯片。我的错误。请检查我下面的代码。该代码工作正常，但代码在使用ActiveWorkbook.Sheets（i）时抛出“脚本超出范围”错误，并且未保存文件。这意味着该脚本正在尝试访问不存在的Excel工作表。你的幻灯片比工作表多吗？保存未完成，因为代码执行被“超出范围”错误中断。谢谢！实际上我想让它更有活力。如果幻灯片少于ppt，脚本是否应该停止。另外，如何将图片粘贴到幻灯片的最右下角。对于第一个问题，请在

i=oSlide.SlideNumber

：如果i>ActiveWorkbook.Sheets.Count，请退出进行

。