Excel VBA从PowerPoint中提取数据 [英] Excel VBA to Extract data from PowerPoint

问题描述

我面临着创建宏以从ppt提取数据的挑战.我需要从ppt表中提取数据并将其粘贴到Excel中.我可以提取数据并将其粘贴到Excel中，但是表格却在另一个下方打印，就像这样:

I have this challenge to create a macro to extract data from ppt. I need to extract the data from tables in a ppt and paste them into Excel. I can extract data and paste it into Excel, but the tables are printing one below the other, like this:

我希望表格像这样打印:

I want the tables to to printed like this:

下面的图片来自ppt，如何将表格放置在ppt中，表格需要以类似的方式打印在Excel电子表格中:

The below image is from ppt how the tables are placed in ppt, in similar way the tables need to be printed in the Excel spreadsheet:

我尝试过:

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

推荐答案

由于 xlRange 是通过搜索 A列中最后使用的单元格定义的，因此您只粘贴到 A列，因此，您当前的输出在此列中是一个接一个.

Because xlRange is defined by searching the last used cell in Column A, you are only pasting to Column A and thus, your current output is one after the other down this column.

您可以保持这种方式，然后将每个表放入Excel中，然后为每个表重新放置"Sub *" 的标题，如果找到，则将其放在行(例如)10上，否则使用与最后一行类似的方法，找到最后一列并向右偏移3列.

You can keep it this way and then reposition each table after they are in Excel by serching each title for "Sub*" and if found put it on row (say) 10 otherwise using a similar method to your last row, find the last column and offset it say, 3 columns to the right.

在您现有的for循环之后类似这样的事情...

Something like this AFTER your existing for loop...

    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

您可能需要更改一些单元格引用，以便它以正确的单元格为目标以查找标题和/或将每个表移动到正确的位置.

You will probably need to change some of the cell references so it targets the right cell to find the title and/or move each table to the correct location.

我也没有根据您当前输出到Excel的格式进行测试.

I also did not test with formatting per your current output to Excel.

我认为可能有一种更清洁的方法来执行此操作，但是这种方法可以实现您的目标.

I think there is probably a cleaner way to do this but this method can achieve your goal.

这篇关于Excel VBA从PowerPoint中提取数据的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！