excel表格转ppt表格

zzpsx

我想把excel中的数据用斑马色填充背景颜色，然后每7行做成一张表格放在ppt中，以下是我的代码，不足之处是转换成的不是表格，而是图片。我要表格。

Sub excel转ppt()
    Rem 每7行斑马色
    Dim ws As Worksheet
    Dim pptApp As Object
    Dim pptPres As Object
    Dim slide As Object
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long, k As Long
    Dim startRow As Long
    Dim cell As Range
    Dim rng As Range
   
    ' 设置要处理的工作表
    Set ws = ThisWorkbook.Sheets("Sheet1") ' 将 "Sheet1" 改为你的工作表名称
   
    ' 查找最后一行和最后一列的数据
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
   
    ' 以斑马线模式填充背景颜色
    For i = 1 To lastRow
        For j = 1 To lastCol
            Set cell = ws.Cells(i, j)
            If Not IsEmpty(cell.Value) Then
                If i Mod 2 = 0 Then
                    cell.Interior.Color = RGB(198, 224, 180) ' 偶数行使用浅灰色
                Else
                    cell.Interior.Color = RGB(255, 255, 255) ' 奇数行使用白色
                End If
            End If
        Next j
    Next i
   
    ' 创建一个新的 PowerPoint 应用程序
    On Error Resume Next
    Set pptApp = GetObject(class:="PowerPoint.Application")
    If pptApp Is Nothing Then
        Set pptApp = CreateObject(class:="PowerPoint.Application")
    End If
    On Error GoTo 0
    pptApp.Visible = True
   
    ' 创建一个新的演示文稿
    Set pptPres = pptApp.Presentations.Add
   
    ' 处理每组7行数据到新的幻灯片中
    For startRow = 1 To lastRow Step 7
        ' 添加一个新的幻灯片
        Set slide = pptPres.Slides.Add(pptPres.Slides.Count + 1, 1) ' 1 是标题和内容的布局
        
        ' 从Excel复制范围到PowerPoint
        Set rng = ws.Range(ws.Cells(startRow, 1), ws.Cells(Application.Min(startRow + 6, lastRow), lastCol))
        rng.Copy
        
        ' 作为表格粘贴到PowerPoint中
        slide.Shapes.PasteSpecial DataType:=2 ' 2 是 ppPasteEnhancedMetafile (EMF) 格式
        
        ' 如果需要，可以在此处格式化粘贴的表格
    Next startRow
   
    ' 设置图片的位置和大小
    For Each slide In pptPres.Slides
        For Each shp In slide.Shapes
            If shp.Type = msoPicture Then
                shp.Left = 30 ' 根据需要调整此值
                shp.Top = 45 ' 根据需要调整此值
                shp.Width = Application.CentimetersToPoints(26.47) ' 设置宽度为 26.47 cm
                shp.Height = Application.CentimetersToPoints(10.17) ' 设置高度为 10.17 cm
            End If
        Next shp
    Next slide
   
    ' 清理
    Set pptApp = Nothing
    Set pptPres = Nothing
    Set slide = Nothing
End Sub
excel表格转ppt表格.zip (46.52 KB, 下载次数: 5)

2024-10-24 09:04 上传

点击文件名下载附件

perfect131

阔以搞 复制粘贴 9楼参考
https://club.excelhome.net/forum ... 642475&pid=11096529

zzpsx

来顶一下。