PPT文字导出到word或excel中,你还在一页一页复制、粘贴?那你不加班谁加班?

背景介绍：

前两天由于工作需要，想把PPT中所有的文字提取到excel中进行编辑，如果一页一页复制再粘贴，太麻烦了，于是想到用VBA提取，VBA代码不会编写？那就让AI帮忙编吧！

下面是AI给出的答复，亲测有效，10秒搞定，需要的小伙伴直接拿走吧，不谢！

Sub ExtractAllTextToWord()
    ' 声明变量
    Dim pptApp As Application, pptPres As Presentation, sld As Slide
    Dim shp As Shape, wordApp As Object, wordDoc As Object
    Dim i As Integer, textContent As String
   
    ' 初始化PPT对象
    Set pptApp = Application
    Set pptPres = ActivePresentation
   
    ' 创建Word对象并显示
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = True
    Set wordDoc = wordApp.Documents.Add
   
    ' 遍历每一页幻灯片
    For Each sld In pptPres.Slides
        i = i + 1
        ' 写入幻灯片编号
        wordDoc.Content.InsertAfter "===== 第" & i & "页幻灯片 ======" & vbCrLf
       
        ' 遍历当前页所有形状
        For Each shp In sld.Shapes
            ' 检查形状是否包含文本
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                    ' 提取文本内容
                    textContent = shp.TextFrame.TextRange.Text
                    ' 过滤空文本
                    If Trim(textContent) <> "" Then
                        wordDoc.Content.InsertAfter textContent & vbCrLf & vbCrLf
                    End If
                End If
            End If
        Next shp
       
        ' 每页之间加分隔线
        wordDoc.Content.InsertAfter "-------------------------" & vbCrLf & vbCrLf
    Next sld
   
    ' 提示完成
    MsgBox "所有文字提取完成！已导出到Word文档。", vbInformation
   
    ' 释放对象
    Set wordDoc = Nothing
    Set wordApp = Nothing
    Set shp = Nothing
    Set sld = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
End Sub

🔈🔈🔈🔈🔈🔈🔈🔈🔈🔈🔈🔈🔈🔈

Sub ExtractAllTextToExcel()

    ' 声明变量

    Dim pptApp As Application, pptPres As Presentation, sld As Slide

    Dim shp As Shape, excelApp As Object, excelWB As Object, excelWS As Object

    Dim rowNum As Integer, shpNum As Integer, i As Integer

    ' 初始化PPT对象

    Set pptApp = Application

    Set pptPres = ActivePresentation

    ' 创建Excel对象并显示

    Set excelApp = CreateObject("Excel.Application")

    excelApp.Visible = True

    Set excelWB = excelApp.Workbooks.Add

    Set excelWS = excelWB.Worksheets(1)

    ' 设置Excel表头

    excelWS.Cells(1, 1) = "幻灯片编号"

    excelWS.Cells(1, 2) = "文本框序号"

    excelWS.Cells(1, 3) = "文字内容"

    ' 表头加粗

    excelWS.Range("A1:C1").Font.Bold = True

    ' 自动调整列宽

    excelWS.Columns("A:C").AutoFit

    rowNum = 2 ' 从第二行开始写入内容

    ' 遍历每一页幻灯片

    For Each sld In pptPres.Slides

        i = i + 1

        shpNum = 0 ' 重置文本框序号

        ' 遍历当前页所有形状

        For Each shp In sld.Shapes

            ' 检查是否有文本

            If shp.HasTextFrame And shp.TextFrame.HasText Then

                shpNum = shpNum + 1

                ' 写入数据到Excel

                excelWS.Cells(rowNum, 1) = i

                excelWS.Cells(rowNum, 2) = shpNum

                excelWS.Cells(rowNum, 3) = shp.TextFrame.TextRange.Text

                rowNum = rowNum + 1

            End If

        Next shp

    Next sld

    ' 提示完成

    MsgBox "所有文字提取完成！已导出到Excel文档。", vbInformation

    ' 释放对象

    Set excelWS = Nothing

    Set excelWB = Nothing

    Set excelApp = Nothing

    Set shp = Nothing

    Set sld = Nothing

    Set pptPres = Nothing

    Set pptApp = Nothing

End Sub

🔈🔈🔈🔈🔈🔈🔈🔈🔈🔈🔈🔈🔈🔈