[英]Extract Text from Powerpoint to Excel
我需要從 powerpoint 中提取一些文本到 excel 中,這是為了工作。 我可以手動完成,但我相信有更好更快的方法。
我實際上並沒有編碼,我確實在 python 和 VBA 中做了一些課程,但我並不是很精通它。 我在網上找到了一些代碼sigma code並嘗試運行它,錯誤在於用戶定義的類型未定義。
有人可以看一下文件並指出正確的方向嗎? 如果我可以提取每個文本框並將其發送到 excel 文件中的單獨列中,那就太好了。
'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
您的用戶定義錯誤可能是因為您沒有使用 Tools->References 添加對 Excel Object 庫的引用。 此宏在 PPTM 文件中運行,不需要引用,因為它使用后期綁定。 它僅導出到新的工作簿文本框,每張幻燈片一行。
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.