如何用VBA把Excel的数据批量复制到PPT之中

星梦月缘

老师好，现在有这样一个需求，Excel表格中的数据已经整理好了，现在需要批量复制粘贴到PPT中，效果如图所示，



处理的逻辑也比较简单
1、运行程序后，新建一个空白的ppt，第一页是封面  输入标题文字 汇报内容。
2、从第二页开始，把Excel中的数据复制到PPT中，只需要复制固定的3行记录即可，标题行+2条记录，总共3行，复制之后到PPT中粘贴时，粘贴方式选择保留源格式，之后调整下适合表格大小，然后再左上角加一个小标题，第 1页数据。
3、PPT第三页，复制固定的3行记录，标题行，,和Excel中第第4行和第5行的内容，循环Excel中的数据的时候，相当于步数是2， 贴方式选择保留源格式，之后调整下适合表格大小，然后再左上角加一个小标题，第 2页数据。
4、继续后面的循环，直到把Excel中的所有数据都粘贴到PPT中，理论上来说如果excel中A列的最后一个非空单元格为lastrow的话，对应的PPT应该是1页封面+   roundup（（lastrow-1）/2）     计算出PPT的总页数。
5、循环完毕之后，保存PPT当当前文件夹之中就可以了。
示例文件已上传。

perfect131

阔以搞 复制粘贴 9楼参考
https://club.excelhome.net/forum ... 75&pid=11096529
如果有偿可以找我

星梦月缘

perfect131 发表于 2024-11-2 20:11
阔以搞 复制粘贴 9楼参考
https://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=164247 ...

好的，谢谢提供学习参考资料。

星梦月缘

====标记此问题已解决，========================================
借鉴其他老师的代码 还有借助AI的力量，写出来一个代码，仅供参考。

1、首先需要准备一个PPT的模板文件，方便调用
2、新建一个sheet，里面做成要复制到PPT的样式，之后循环总数据，依次写入这个sheet之中，之后创建PPT，粘贴到PPT之中，依次全部循环，
相关的代码如下：

Sub ExportToPPT()
    Dim pptApp As Object
    Dim pptPres As Object
    Dim slideIndex As Integer
    Dim lastRow As Long
    Dim i As Integer
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim dataRange As Range
    Dim templatePath As String

    ' 设置 Excel 工作表
    Set sourceSheet = Sheet4 ' 表1
    Set targetSheet = Sheet1 ' 表2

    ' 清空目标工作表
    targetSheet.Range("a2:f3").ClearContents
   targetSheet.Range("a2:f3").Interior.Color = RGB(242, 242, 242)

    ' 获取源工作表最后一个非空单元格的行数
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, 1).End(xlUp).Row
      If lastRow Mod 2 = 0 Then lastRow = lastRow + 1
   
    ' 创建 PowerPoint 应用
    On Error Resume Next
    Set pptApp = GetObject(, "PowerPoint.Application")
    If pptApp Is Nothing Then
        Set pptApp = CreateObject("PowerPoint.Application")
    End If
    On Error GoTo 0
   
    ' 指定模板路径
    templatePath = ThisWorkbook.Path & "\model.potx"
   
    ' 使用模板创建新的演示文稿
    Set pptPres = pptApp.Presentations.Open(templatePath)

    ' 循环处理源工作表的数据
    For i = 2 To lastRow Step 2
   
        ' 复制当前行数据到目标工作表
        'sourceSheet.Rows(i).Copy targetSheet.Rows(i)
       sourceSheet.Range("A" & i & ":F" & (i + 1)).Copy targetSheet.Range("A2")
       targetSheet.Range("A2:F3").Rows.AutoFit
        ' 在 PowerPoint 中新增一页幻灯片
        Dim contentSlide As Object
        Set contentSlide = pptPres.Slides.Add(i / 2 + 1, ppLayoutText) ' +1因为第一页是封面
        
        ' 设置标题
        contentSlide.Shapes(1).TextFrame.TextRange.Text = "第 " & i / 2 & " 页"

        ' 定义要复制的区域
        Set dataRange = targetSheet.Range("A1:F3") ' 假设只复制到 F 列

        ' 复制数据
        dataRange.Copy

        ' 切换到 PowerPoint 并粘贴
        contentSlide.Shapes.Paste

        ' 调整表格大小
        With contentSlide.Shapes(contentSlide.Shapes.Count) ' 获取最新粘贴的形状
            .LockAspectRatio = msoFalse
            .Width = 890 ' 根据需要调整宽度
            .Height = 430 ' 根据需要调整高度
            .Top = 100 ' 根据需要调整位置
            .Left = 50 ' 根据需要调整位置
        End With
    Next i
   
    ' 保存演示文稿
    pptPres.SaveAs ThisWorkbook.Path & "\Presentation.pptx"
    pptPres.Close
    pptApp.Quit

    ' 清理对象
    Set pptPres = Nothing
    Set pptApp = Nothing
    Set sourceSheet = Nothing
    Set targetSheet = Nothing
    Set dataRange = Nothing
   
    MsgBox "生成完毕"
End Sub