从 PPT 中提取文本并使用 VBA 将其粘贴到 Excel

Question

我需要从 PowerPoint 演示文稿的文本框中提取数据，并将它们放入 Excel 作品sheet 的相应单元格中。

我已搜索但找不到合适的解决方法。

此代码用于打印幻灯片中的文本。我不明白如何在 Excel 个单元格中排列它。

Dim oPApp As Object
Dim oSlide As Object
Dim oShape As Object
    
Set oPApp = GetObject(, "PowerPoint.Application")
    
For Each oSlide In oPApp.ActivePresentation.Slides
    For Each oShape In oSlide.Shapes
        
        If oShape.Type = 1 Or oShape.Type = 14 Then
            Debug.Print oShape.TextFrame.TextRange.Text
        End If
            
    Next oShape
Next oSlide
    
Set oPApp = Nothing

幻灯片示例（输入）：

sheet（输出）示例：

Answer 1

假设您希望它从 Excel 模块完成（也可以从 PowerPoint 模块完成），我只是向您的代码添加一些代码和建议。然而，在 PowerPoint 幻灯片中循环遍历形状时要提到它通常按形状的创建顺序出现。因此，为了保持字段的正确顺序，您必须根据它们的位置（即顶部、左侧属性或根据演示文稿的任何其他标准）制定出某种方式对它们进行排序。尝试

    Dim oPApp As Object
    Dim oSlide As Object
    Dim oShape As Object

    Dim Rw, StCol, Col, Sht As Long
    Rw = 2     'Starting Row of Target excel data
    StCol = 1   'Starting Column of Target excel data
    Sht = 3   'Target Worksheet no.

    Set oPApp = GetObject(, "PowerPoint.Application")
    'It will only work for already opened active presentation
    'It can also be suugested that first create a powerpoint object and then open desired preesntation fron the path

    For Each oSlide In oPApp.ActivePresentation.Slides
    Col = StCol
        For Each oShape In oSlide.Shapes
            If oShape.Type = 1 Or oShape.Type = 14 Then
            '    Debug.Print oShape.TextFrame.TextRange.Text
            'Next line was added for putting the data into excel sheet
            ThisWorkbook.Sheets(Sht).Cells(Rw, Col).Value = 
 oShape.TextFrame.TextRange.Text
            End If
        Col = Col + 1
        Next oShape
    Rw = Rw + 1
    Next oSlide

    Set oPApp = Nothing

但是需要注意的是 msoTextBox 类型是 17，类型 14 是 msoPlaceholder。

从 PPT 中提取文本并使用 VBA 将其粘贴到 Excel

Extracting text from PPT and pasting it in Excel using VBA

excel

powerpoint

vba