Excel VBA 從 PowerPoint 中提取數據

Question

我有這個挑戰來創建一個宏來從 ppt 中提取數據。 我需要從ppt中的表格中提取數據並將它們粘貼到Excel中。 我可以提取數據並將其粘貼到 Excel 中，但表格打印在另一個下方，如下所示：

我希望表格像這樣打印：

下圖來自ppt表格是如何放置在ppt中的，類似的表格需要打印在Excel電子表格中：

我試過這個：

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

Answer 1

因為xlRange是通過搜索Column A中最后使用的單元格來定義的，所以您只粘貼到Column A ，因此，您當前的 output 在此列中一個接一個。

您可以保持這種方式，然后在 Excel 中重新定位每個表，方法是為"Sub*"搜索每個標題，如果找到將其放在第 10 行（例如），否則使用與最后一行類似的方法，找到最后一列並偏移它說，向右 3 列。

在你現有的 for 循環之后這樣的事情......

    Dim RowCounter As Long
    Dim BottomRowOfTable As Long
    Dim LastColumn As Long
    Dim MyArray As Variant
    For RowCounter = 1 To xlRange    'You can reuse this as the last destination which would be the last header row in the list you pasted.
        With xlSheet
            If .Cells(RowCounter, 1).Value Like "Sub*" Then
                BottomRowOfTable = .Cells(RowCounter, 1).End(xlDown).Row
                LastColumn = .Cells(8, .Columns.Count).End(xlToLeft).Column
                MyArray = .Range(.Cells(RowCounter, 1), .Cells(BottomRowOfTable, 1)).Value
                .Range(.Cells(8, LastColumn + 2).Address).Resize(UBound(MyArray)).Value = MyArray
                .Range(.Cells(RowCounter, 1), .Cells(BottomRowOfTable, 1)).Clear
            ElseIf .Cells(RowCounter, 1).Value Like "Station*" Then
                BottomRowOfTable = .Cells(RowCounter, 1).End(xlDown).Row
                LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
                MyArray = .Range(.Cells(RowCounter, 1), .Cells(BottomRowOfTable, 1)).Value
                .Range(.Cells(1, LastColumn + 2).Address).Resize(UBound(MyArray)).Value = MyArray
                .Range(.Cells(RowCounter, 1), .Cells(BottomRowOfTable, 1)).Clear
            End If
        End With
    Next RowCounter

您可能需要更改一些單元格引用，以便它定位正確的單元格以查找標題和/或將每個表格移動到正確的位置。

我也沒有根據您當前的 output 到 Excel 進行格式化測試。

我認為可能有一種更清潔的方法可以做到這一點，但這種方法可以實現您的目標。