如何用vba把excel转换成ppt ppt中每页7行，字体尽量最大化

zzpsx

如何用vba把excel转换成ppt

ppt中每页7行表格，字体尽量最大化，
用vba把excel转换成ppt.7z (8.83 KB, 下载次数: 13)

2024-9-23 08:59 上传

点击文件名下载附件

Yalishanda30

e........

zzpsx

谢谢高手，不过原excel中有4列表格，转换好的ppt上好像只有两列，还缺2列。
还有，上面的slide 1不要，尽量让表格撑满整个ppt页面。

Yalishanda30

zzpsx 发表于 2024-9-23 10:23
谢谢高手，不过原excel中有三列表格，转换好的ppt上好像只有两列，还缺一列。
还有，上面的slide 1不要， ...

随手一改就行，除非你啥也不会

zzpsx

谢谢高手，我修改到以下效果了，代码在图下面。如何继续修改代码，删除ppt中的标题文本框，让正文文本框最大化适应ppt页面，并让ppt中的表格按照文字长短自动调整列宽，




Const ppLayoutTitle = 1
Const ppLayoutText = 2

Sub ExcelToPPT()
    Dim data_array As Variant
    Dim lstRow As Integer
    Dim slides_count As Integer
    Dim objPPT As Object
    Dim objPresentation As Object
    Dim pptSlide As Object
    Dim objTbl As Object
    Dim lRow As Byte
    Dim lCol As Byte
    Dim i As Integer

    With Sheet1
        lstRow = .Range("D1048576").End(xlUp).Row ' 假设数据直到列D
        data_array = .Range("A1").Resize(lstRow, 4).Value ' 读取A、B、C、D四列数据
    End With

    slides_count = Application.Ceiling(lstRow / 7, 1)
    Set objPPT = CreateObject("PowerPoint.Application")
    objPPT.Visible = True
    Set objPresentation = objPPT.Presentations.Add

    With objPresentation
        .Slides.Add Index:=1, Layout:=ppLayoutTitle
        For i = 1 To slides_count
            Set pptSlide = .Slides.Add(i, ppLayoutText)
            Set tbl = pptSlide.Shapes.AddTable(7, 4, 65, 145, 830, 310) ' 创建4列的表格
            Set objTbl = pptSlide.Shapes(3).Table
            With objTbl
                For lRow = 1 To 7
                    startRow = (i - 1) * 7 + lRow
                    If startRow <= lstRow Then
                        For lCol = 1 To 4 ' 遍历4列
                            With .cell(lRow, lCol).Shape.TextFrame.TextRange
                                .Font.Name = "Tahoma(Body)"
                                .Font.Size = 32
                                .Font.Color = RGB(64, 65, 70)
                                .Text = data_array(startRow, lCol)
                            End With
                        Next
                    End If
                Next
            End With
        Next i
        .SaveAs ThisWorkbook.Path & "\Sample.pptx"
    End With
End Sub

Yalishanda30

zzpsx 发表于 2024-9-23 13:43
谢谢高手，我修改到以下效果了，代码在图下面。如何继续修改代码，删除ppt中的标题文本框，让正文文本框最 ...

不支持自适应列宽，只能单独设置了

lss001

zzpsx 发表于 2024-9-23 13:43
谢谢高手，我修改到以下效果了，代码在图下面。如何继续修改代码，删除ppt中的标题文本框，让正文文本框最 ...

'表格使用复制粘贴比较合理

Sub exceltoppt()
    Dim rng As Range, ppt As Object
    Dim pre As Object, sld As Object
    Dim x%, y%, i%, j%, s$, k&, t As Date
   
    Set rng = Sheet1.UsedRange
    r = rng.Rows.Count '行数
    c = rng.Columns.Count '列数
    y = r Mod 7 '余数
    If y Then k = 1 Else k = 0
    x = r \ 7 + k '页数
   
    Set ppt = CreateObject("PowerPoint.Application")
    ppt.Activate '激活
    Set pre = ppt.Presentations.Add '新建
    t = Timer '延时
    While Timer < t + 1: DoEvents: Wend
    ppt.Windows(1).View.Zoom = 60 '缩放
    ppt.ActiveWindow.Panes(1).Activate
   
    For i = x To 1 Step -1 '倒循环
        Set sld = pre.slides.Add(1, 12) '空白页
        If i < x Or y = 0 Then k = 7 Else k = y
        j = (i - 1) * 7
        Application.CutCopyMode = False '剪贴板
        Range(Cells(j + 1, 1), Cells(j + k, c)).Copy '复制表
        With sld.Shapes '设置表
            .PasteSpecial ppPasteDefault '粘贴表
            .Range.Left = 0 '左边距
            .Range.Top = 0 '上边距
            .Range.Table.ScaleProportionally 3.25 '缩放比
        End With
    Next

    t = Timer '延时等待
    While Timer < t + 1: DoEvents: Wend
    pre.SaveAs ThisWorkbook.Path & "\words2.pptx" '保存文件
    Set sld = Nothing '释放对象
    Set pre = Nothing
    Set ppt = Nothing
    Set rng = Nothing

End Sub

zzpsx

lss001 发表于 2024-9-23 17:27
'表格使用复制粘贴比较合理

Sub exceltoppt()

lss001

zzpsx 发表于 2024-9-23 18:38

变一下改一下
Dim pre As Object, sld As Object