将Powerpoint表格中的文本导入Excel

我目前正在使用VBA编写一个代码，该代码将自动将Powerpoint幻灯片中表格中的文本作为文本或表格导入Excel

幻灯片如下所示：

***根据Technodabler帮助更新代码

    Public Sub CopySlideShapesText()

    ' Update the PowerPoint file name
    Const cPowerPointName = "test.pptx"

    Dim vPowerPoint As PowerPoint.Application
    Dim vPresentation As PowerPoint.Presentation
    Dim vSlide As PowerPoint.Slide
    Dim vPowerpointShape As PowerPoint.Shape
    Dim vSheet As Worksheet
    Dim vRowCounter As Long

    ' Open the powerpoint presentation
    Set vPowerPoint = New PowerPoint.Application
    Set vPresentation = vPowerPoint.Presentations.Open(cPowerPointName)

    ' Write the slide info onto the active excel sheet
    Set vSheet = ActiveSheet

    ' Loop through each of the slides
    vRowCounter = 1
    For Each vSlide In vPresentation.Slides

        ' Loop through each shape on the slide
        For Each vPowerpointShape In vSlide.Shapes

            ' If shape isn't a table ... copy the text
            If Not vPowerpointShape.HasTable Then
                vPowerpointShape.Copy
                vSheet.Range("A" & vRowCounter) = vPowerpointShape.TextFrame2.TextRange.Text
                vRowCounter = vRowCounter + 1
            Else
                vPowerpointShape.Copy
                vSheet.Range("A" & vRowCounter).Select
                vSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
                vRowCounter = vRowCounter + vPowerpointShape.Table.Rows.Count
            End If
        Next
    Next

    vPresentation.Close
    vPowerPoint.Quit

End Sub

更新

错误显示

---

@Excelsson。。。桌子是一种形状，但需要区别对待；您可以将其粘贴为一个整体实体。。。或者可以在形状（包含表）中的行和列之间循环。下面是一个代码示例，它循环遍历所有幻灯片，然后遍历幻灯片上的所有形状，如果是简单形状，则在文本中复制，或者如果形状包含表格，则在中复制整个表格并进入下一个形状（考虑表中的行数）：

它产生的一个例子：

Powerpoint幻灯片：

Excel输出：

如果要循环遍历表的行和列（或者更准确地说是包含表的形状），可以根据以下答案改编代码：

---

干杯。。。桌子是一种形状，但需要区别对待；您可以将其粘贴为一个整体实体。。。或者可以在形状（包含表）中的行和列之间循环。下面是一个代码示例，它循环遍历所有幻灯片，然后遍历幻灯片上的所有形状，如果是简单形状，则在文本中复制，或者如果形状包含表格，则在中复制整个表格并进入下一个形状（考虑表中的行数）：

它产生的一个例子：

Powerpoint幻灯片：

Excel输出：

如果要循环遍历表的行和列（或者更准确地说是包含表的形状），可以根据以下答案改编代码：

---

干杯

效果很好，但是，在加载幻灯片1的表格后，它被卡住了，当关闭PPT时，会显示指定值超出范围的错误，有任何线索吗？此外，如何修改它以检索所有幻灯片，而不仅仅是第一张，您的代码肯定是有意义的@Excelsson-更新答案，以循环浏览多张幻灯片，但仍写入单个活动工作表。不确定是什么导致了错误。。。您需要调试生成错误的特定行。干杯。我用错误和显示@Technodabler的行项目更新了问题。我很感激，必须说幻灯片中还有两个其他对象，是吗？@Excelsson您可能有没有文本的形状。。。因此，在代码中添加额外的检查（.hastext）。否则，您将不得不调试触发错误的对象/形状的特性。这样做了，.hastext肯定让它工作得很好，但是，它在加载幻灯片1的表格后卡住了，当关闭PPT时，会显示指定值超出范围的错误，有线索吗？此外，如何修改它以检索所有幻灯片，而不仅仅是第一张，您的代码肯定是有意义的@Excelsson-更新答案，以循环浏览多张幻灯片，但仍写入单个活动工作表。不确定是什么导致了错误。。。您需要调试生成错误的特定行。干杯。我用错误和显示@Technodabler的行项目更新了问题。我很感激，必须说幻灯片中还有两个其他对象，是吗？@Excelsson您可能有没有文本的形状。。。因此，在代码中添加额外的检查（.hastext）。否则，您将不得不调试触发错误的对象/形状的特性

Option Explicit

' ---> ADD REFERENCE TO MICROSOFT POWERPOINT OBJECT LIBRARY

Public Sub CopySlideShapesText()

    ' Update the PowerPoint file name
    Const cPowerPointName = "test.pptx"

    Dim vPowerPoint As PowerPoint.Application
    Dim vPresentation As PowerPoint.Presentation
    Dim vSlide As PowerPoint.Slide
    Dim vPowerpointShape As PowerPoint.Shape
    Dim vSheet As Worksheet
    Dim vRowCounter As Long

    ' Open the powerpoint presentation
    Set vPowerPoint = New PowerPoint.Application
    Set vPresentation = vPowerPoint.Presentations.Open(cPowerPointName)

    ' Write the slide info onto the active excel sheet
    Set vSheet = ActiveSheet

    ' Loop through each of the slides
    vRowCounter = 1
    For Each vSlide In vPresentation.Slides

        ' Loop through each shape on the slide
        For Each vPowerpointShape In vSlide.Shapes

            ' If shape isn't a table ... copy the text
            If Not vPowerpointShape.HasTable Then
                If vPowerpointShape.TextFrame2.HasText Then
                    vPowerpointShape.Copy
                    vSheet.Range("A" & vRowCounter) = vPowerpointShape.TextFrame2.TextRange.Text
                    vRowCounter = vRowCounter + 1
                End If
            Else
                vPowerpointShape.Copy
                vSheet.Range("A" & vRowCounter).Select
                vSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
                vRowCounter = vRowCounter + vPowerpointShape.Table.Rows.Count
            End If
        Next
    Next

    vPresentation.Close
    vPowerPoint.Quit

End Sub