问题描述
我需要从PowerPoint中提取一些文本到excel中,这是为了工作.我可以手动完成此操作,但我相信有更好,更快的方法.
I need to extract some text from powerpoint into excel, it's for a work thing. I could do it manually but I am sure there is a much better and faster way.
我实际上并没有编写代码,我确实在python和VBA中做了一些类,但是我并不是很精通.我在网上找到了一些代码 sigma代码并尝试运行它,这是一个错误,因为用户定义的类型未定义.
I do not actually code, I did do some classes in python and VBA but I am not really proficient in it. I found some code online sigma code and tried to run it, there's an error in that the user-defined type being undefined.
有人可以看看文件并指出正确的方向?如果我可以将每个文本框提取并发送到excel文件中的单独列中,那就太好了.
Could someone take a look at the file and point me in the right direction? If I could just extract and send each text box into separate columns in the excel file, that would be great.
'Declare our Variables
Dim PPTPres As Presentation
Dim PPTSlide As Slide
Dim PPTShape As Shape
Dim PPTTable As Table
Dim PPTPlaceHolder As PlaceholderFormat
'Declare Excel Variables.
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlWrkSheet As Excel.Worksheet
Dim xlRange As Excel.Range
'Grab the Currrent Presentation.
Set PPTPres = Application.ActivePresentation
'Keep going if there is an error
On Error Resume Next
'Get the Active instance of Outlook if there is one
Set xlApp = GetObject(, "Excel.Application")
'If Outlook isn't open then create a new instance of Outlook
If Err.Number = 429 Then
'Clear Error
Err.Clear
'Create a new Excel App.
Set xlApp = New Excel.Application
'Make sure it's visible.
xlApp.Visible = True
'Add a new workbook.
Set xlBook = xlApp.Workbooks.Add
'Add a new worksheet.
Set xlWrkSheet = xlBook.Worksheets.Add
End If
'Set the Workbook to the Active one, if Excel is already open. THIS ASSUMES WE HAVE A WORKBOOK IN THE EXCEL APP.
Set xlBook = xlApp.Workbooks("ExportFromPowerPointToExcel.xlsm")
'Set the Worksheet to the Active one, if Excel is already open. THIS ASSUMES WE HAVE A WORKSHEET IN THE WORKBOOK.
Set xlWrkSheet = xlBook.Worksheets("Slide_Export")
'Loop through each Slide in the Presentation.
For Each PPTSlide In PPTPres.Slides
'Loop through each Shape in Slide.
For Each PPTShape In PPTSlide.Shapes
'If the Shape is a Table.
If PPTShape.Type = msoPlaceholder Or PPTShape.Type = ppPlaceholderVerticalObject Then
'Grab the Last Row.
Set xlRange = xlWrkSheet.Range("A100000").End(xlUp)
'Handle the loops that come after the first, where we need to offset.
If xlRange.Value <> "" Then
'Offset by One rows.
Set xlRange = xlRange.Offset(1, 0)
End If
'Grab different Shape Info and export it to Excel.
xlRange.Value = PPTShape.TextFrame.TextRange
xlRange.Offset(0, 1).Value = PPTSlide.Name
xlRange.Offset(0, 2).Value = PPTSlide.SlideIndex
xlRange.Offset(0, 3).Value = PPTSlide.Layout
xlRange.Offset(0, 4).Value = PPTShape.Name
xlRange.Offset(0, 5).Value = PPTShape.Type
End If
Next
Next
'Set the Worksheet Column Width.
xlWrkSheet.Columns.ColumnWidth = 20
'Set the Worksheet Row Height.
xlWrkSheet.Rows.RowHeight = 20
'Set the Horizontal Alignment so it's to the Left.
xlWrkSheet.Cells.HorizontalAlignment = xlLeft
'Turn off the Gridlines.
xlApp.ActiveWindow.DisplayGridLines = False
End Sub
推荐答案
您用户定义的错误可能是因为您尚未使用工具->参考添加对Excel对象库的引用.此宏在PPTM文件中运行,并且不需要引用,因为它使用 late绑定.它仅导出到新的工作簿文本框中,每张幻灯片一行.
Your user-defined error is probably because you haven't added a reference to the Excel Object Library using Tools->References. This macro runs in the PPTM file and doesn't need the reference as it uses late binding. It exports to new workbook text boxes only, one row for each slide.
Option Explicit
Sub ExportToExcel()
'Declare variables
Const WB_NAME = "ExportFromPowerPointToExcel.xlsx"
Const WS_NAME = "Slide_Export"
Dim PPTPres As Presentation, PPTSlide As Slide, PPTShape As Shape
Dim PPTTable As Table
Dim PPTPlaceHolder As PlaceholderFormat
' create workbook
Dim xlApp, wb, ws
Set xlApp = CreateObject("Excel.Application")
Dim iRow As Long, c As Integer, folder As String
'Set xlApp = New Excel.Application
xlApp.Visible = True
Set wb = xlApp.Workbooks.Add
Set ws = wb.Worksheets(1)
ws.Name = WS_NAME
iRow = 2
'Grab the Currrent Presentation.
Set PPTPres = Application.ActivePresentation
'Loop through each Slide in the Presentation.
For Each PPTSlide In PPTPres.Slides
'Loop through each Shape in Slide.
For Each PPTShape In PPTSlide.Shapes
If PPTShape.HasTextFrame Then
c = PPTShape.Id + 1
' headings
If ws.Cells(1, c) = "" Then
ws.Cells(1, c) = PPTShape.Name
End If
ws.Cells(iRow, c) = PPTShape.TextFrame.TextRange
End If
Next
ws.Cells(iRow, 1) = PPTSlide.Name
iRow = iRow + 1
Next
With ws
.Columns.ColumnWidth = 20
.Rows.RowHeight = 20
.Columns.HorizontalAlignment = xlLeft
End With
xlApp.ActiveWindow.DisplayGridLines = False
' save
folder = PPTPres.Path & "\"
xlApp.DisplayAlerts = False
wb.SaveAs folder & WB_NAME
xlApp.DisplayAlerts = True
wb.Close False
' quit excel
xlApp.Quit
Set xlApp = Nothing
MsgBox "File saved to " & folder & WB_NAME
End Sub
这篇关于从Powerpoint提取文本到Excel的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持!