Excel VBA提取PowerPoint表格并按PPT布局对齐导出至Excel的实现

当前实现现状 #

• 已达成基础能力：通过VBA宏实现PowerPoint内表格数据提取、粘贴至Excel的核心流程
• 现存问题：所有导出的表格在Excel中均为上下堆叠排列，未匹配PPT内的原有布局
• 效果参考：
  • 当前导出效果：
  • 期望导出效果：
  • 需匹配的PPT内表格布局规则参考：

当前使用的VBA代码 #

Sub ExportToExcelSheet()
'Declare PPT variables
     Dim pptPres As Presentation
     Dim pptSlide As Slide
     Dim pptShape As Shape
     Dim pptPlaceholder As PlaceholderFormat
     Dim pptTable As Table
'Declare Excel variables
     Dim xlApp As Excel.Application
     Dim xlBook As Excel.Workbook
     Dim xlSheet As Excel.Worksheet
     Dim xlRange As Excel.Range

'Access the active presentation
     Set pptPres = Application.ActivePresentation

On Error Resume Next
     Set xlApp = GetObject(, "EXCEL.Application")
     If Err.Number = 429 Then
         Err.Clear
         Set xlApp = New Excel.Application
         xlApp.Visible = True
         Set xlBook = xlApp.Workbooks.Add
         Set xlSheet = xlBook.Worksheets.Add
     End If

     Set xlBook = xlApp.Workbooks("Extract.xlsx")
     Set xlSheet = xlBook.Worksheets("Sheet1")

     For Each pptSlide In pptPres.Slides
        For Each pptShape In pptSlide.Shapes
           If pptShape.Type = msoTable Then
              Set pptTable = pptShape.Table
              pptShape.Copy
              Set xlRange = xlSheet.Range("A100").End(xlUp)
              If xlRange.Address <> "$A$1" Then
                  Set xlRange = xlRange.Offset(3, 0)
              End If
              xlSheet.Paste Destination:=xlRange
           End If
         Next
     Next

       xlSheet.Columns.Range("A1").ColumnWidth = 5
       xlSheet.Columns.Range("B1").ColumnWidth = 25
       xlSheet.Rows.RowHeight = 20
End Sub

优化方向诉求 #

需调整VBA逻辑，让导出到Excel的表格排布完全匹配PPT页面内的表格相对位置，替代当前逐行上下堆叠的导出逻辑。

内容的提问来源于stack exchange，提问作者user228502