[已解决]VBA自动生成PPT贺报

百里图苏

最佳答案

月排行榜 / 总排行榜

ahn

2022-2-8 16:10

PowerPoint VBA很少使用。
测试过程中发现：需要给复制幻灯片、粘贴幻灯片、给文本框写入文字等操作留有一定的响应时间。

跳转到最佳答案楼层

ahn

PowerPoint VBA很少使用。
测试过程中发现：需要给复制幻灯片、粘贴幻灯片、给文本框写入文字等操作留有一定的响应时间。

百里图苏

自学的代码
Sub 贺报生成()

    Dim weizhi As String
    Dim idx As Integer
    Dim wb1 As String, wb2 As String, wb3 As String

   Path = ActivePresentation.Path

  weizhi = Path & "\贺报一键生成贺报数据.xlsx"

    wb1 = "文本1"
    wb2 = "文本2"
    wb3 = "文本3"
    wb4 = "文本4"
    Dim MyexcelApp As New Excel.Application
    Dim MyexcelBook As New Excel.Workbook
    Dim MyexcelSheet As New Excel.Worksheet
    Pathstr = weizhi
    Set MyexcelBook = MyexcelApp.Workbooks.Open(Pathstr)
    Set MyexcelSheet = MyexcelBook.Worksheets(1)
    MyexcelSheet.Activate
    Dim i As Integer

        Dim oPPT As Presentation
        Dim oSlide As Slide
        '当前ppt演示文稿
        Set oPPT = PowerPoint.ActivePresentation
                With oPPT
            '第一个幻灯片
             Set oSlide = .Slides(1)
            '复制到剪贴板
            oSlide.Copy



        End With
    For i = 1 To 1000

            '粘贴使其成为第2个幻灯片
            oPPT.Slides.Paste (i + 1)

        ActivePresentation.Slides(i + 1).Shapes(wb1).TextFrame.TextRange.Text = MyexcelSheet.Cells(i + 1, 1).Value '地区
        ActivePresentation.Slides(i + 1).Shapes(wb2).TextFrame.TextRange.Text = MyexcelSheet.Cells(i + 1, 2).Value '地区


        If MyexcelSheet.Cells(i + 2, 1).Value = "" Then

    MyexcelBook.Close


    Set MyexcelApp = Nothing
    Set MyexcelBook = Nothing
    Set MyexcelSheet = Nothing
            Exit Sub
        End If
    Next i

    MyexcelApp.Workbooks.Close
    MyexcelBook.Close
    MyexcelApp.Close

    Set MyexcelApp = Nothing
    Set MyexcelBook = Nothing
    Set MyexcelSheet = Nothing
End Sub
改代码只设置了两个可变的文本框，后期运用起来较麻烦，想要实现全自动化的一个流程，求各位老师帮助改进，非常感谢！

百里图苏

原始效果里面只设置了两可变量的文本框（标白部分）

百里图苏

求求不要沉啊

百里图苏

日常求助自顶