我正在与一家大型公司实习，该公司以PowerPoints的形式存储了大量的源数据。这些PowerPpoints在跨部门和供应商之间进行通信时很有用，但正如您可能猜测的那样，缺乏可靠的分析。因此，我决定将这些Powerpoint数据库编入Access。
我知道，没有直接的方法可以做到这一点。由于严格的IT策略，我仅限于VBA作为我的编码平台。我花了最后一周编写一个宏来解决我的问题。同样，由于没有PowerPoint直接转换为Access，我不得不相当低效地解决这个问题，因为有一些警告。我将在下面列出我的步骤和注意事项。
我想要数据库的powerpoint信息被格式化为表而不是文本。我一直无法找到将PPT表直接转换为Excel或CSV文件的宏。因此，我会将所有PPT文件（大约3000个）转换为PDF格式。
从这些生成的PDF中我可以使用Adobe将它们转换为Excel或CSV文件。
使用多个在线资源和我自己的一些经验，我编写了一个VBA脚本，该脚本会自动将CSV文件的文件格式化为Access将正确存储的格式。见代码1.
格式化CSV后，我会将它们全部自动化为Access。
在Access自动化之后，我需要将每个PPT文件嵌入其各自的Access条目
同样，这不是一个有效的过程。因为我仅限于Microsoft的应用程序，所以我选择了这条路线。我想将信息保留为Excel文件，但我们的想法是让任何部门都可以访问和搜索这些数据，因此我选择了Access数据库。
既然我已经向你解释了我来自哪里以及我在做什么，我会问：你对我有什么建议？我觉得我的循环方式是一个很好的解决方案和实用方法，但我想知道是否有更好的解决方案。
Sub LoopCSVFile()
Dim fso As Object 'Scritping.FileSystemObject
Dim fldr As Object 'Scripting.Folder
Dim file As Object 'Scripting.File
Dim wb As Workbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = fso.GetFolder("C:\Users\HMM105289\Documents\Powerpoint Parsing\Test Folder\Test Save Folder")
For Each file In fldr.Files
Set wb = Workbooks.Open(file.Path)
Application.Run "Personal.xlsb!Module1.FormatAccess"
wb.Close SaveChanges = True
Next
Set file = Nothing
Set fldr = Nothing
Set fso = Nothing
End Sub
在讨论了Tim的一些建议之后，我想出了这个代码来检查每个PPT幻灯片。这个想法是让它在里面运行他的“ExtractTable”宏。就目前而言，我无法让它执行。
Sub PPTableXtraction()
Dim oSlide As Slide
Dim oSlides As Slides
Dim oPPT As Object: Set oPPT = ActivePresentation
Dim oShapes As Shape
Dim oTable As Object
For Each oSlide In oPPT.Slides
For Each oShapes In oSlide.Shapes
If oShapes.HasTable Then
Application.Run "VBAProject.xlsb!Module3.ExtractTableContent"
End If
Next
Next
End Sub
我能够在Tim的代码上构建一个代码来循环每个PowerPoint文件并将信息提取到Excel中。代码不会进入调试器，但无论出于何种原因，它都没有执行任何功能。有人会有任何想法吗？
Sub Tester()
Dim ppts As PowerPoint.Application
Dim FolderPath As String
Dim FileName As String
FolderPath = "FolderPath"
FileName = Dir(FolderPath & "*.ppt*")
Do While FileName <> ""
Set ppts = New PowerPoint.Application
ppts.Visible = True
ppts.Presentations.Open FileName:=FolderPath & FileName
A = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 5
B = "B" & A
X = "A" & A
Range(X).Value = "New"
Dim ppt As Object, tbl As Object
Dim slide As Object, pres As Object, shp
Dim rngDest As Range
Set ppt = GetObject(, "Powerpoint.Application")
Set pres = ppt.ActivePresentation
Set rngDest = Sheets("Data").Range(B) '
For Each slide In pres.Slides
For Each shp In slide.Shapes
If shp.HasTable Then
ExtractTableContent shp.Table, rngDest
Set rngDest = rngDest.Offset(shp.Table.Rows.Count + 3, 0)
End If
Next
Next
ppts.ActivePresentation.Close
FileName = Dir
Loop
End Sub
Sub ExtractTableContent(oTable As Object, rng As Range)
Dim r, c, offR As Long, offC As Long
For Each r In oTable.Rows '<< Loop over each row in the PPT table
offC = 0 '<< reset the column offset
For Each c In r.Cells '<< Loop over each cell in the row
'Copy the cell's text content to Excel, using the offsets
' offR and offC to select where it gets placed relative
' to the starting point (rng)
rng.Offset(offR, offC).Value = c.Shape.TextFrame.TextRange.Text
offC = offC + 1 '<< increment the column offset
Next c
offR = offR + 1 '<< increment the row offset
Next r
End Sub
Sub N()
Range("A3").Value = "New"
End Sub
答案 0 :(得分：2)
这是一个从PPT提取表到Excel的示例。
循环播放幻灯片和表格（根据您发布的代码进行修改）
Sub Tester()
Dim ppt As Object, tbl As Object
Dim slide As Object, pres As Object, shp
Dim rngDest As Range
Set ppt = GetObject(, "Powerpoint.Application")
Set pres = ppt.ActivePresentation
Set rngDest = Sheets("Data").Range("a1") '<< where to start placing ppt data
For Each slide In pres.Slides
For Each shp In slide.Shapes
If shp.HasTable Then
ExtractTableContent shp.Table, rngDest
Set rngDest = rngDest.Offset(shp.Table.Rows.Count + 3, 0)
End If
Next
Next
End Sub
提取每个表的数据的子
Sub ExtractTableContent(oTable As Object, rng As Range)
Dim r, c, offR As Long, offC As Long
For Each r In oTable.Rows '<< Loop over each row in the PPT table
offC = 0 '<< reset the column offset
For Each c In r.Cells '<< Loop over each cell in the row
'Copy the cell's text content to Excel, using the offsets
' offR and offC to select where it gets placed relative
' to the starting point (rng)
rng.Offset(offR, offC).Value = c.Shape.TextFrame.TextRange.Text
offC = offC + 1 '<< increment the column offset
Next c
offR = offR + 1 '<< increment the row offset
Next r
End Sub
答案 1 :(得分：0)
如果有人抓住这个并希望使用解决方案
除了设置文件路径外，它已经开箱即用了。
Sub Tester()
Dim rng As Range
Set rng = Range("A1") 'This code is necessary to prevent a constant loop of the formatting for each extraction. It adds a "1" into "A1"
rng.Value = 1
Dim ppts As PowerPoint.Application
Dim FolderPath As String
Dim FileName As String
FolderPath = "FolderPath" 'Define your Folder Path
FileName = Dir(FolderPath & "*.ppt*") 'Locate .PPT files
Do While FileName <> ""
Set ppts = New PowerPoint.Application 'Left this in after finding another fix. Opens new instance each time
ppts.Visible = True
ppts.Presentations.Open FileName:=FolderPath & FileName
'The code below sets 3 variables to help in formatting Tim's extraction code.
'It searches for the last cell entry and then adds 5 rows before copying more information.
A = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 5
B = "B" & A
X = "A" & A
Range(X).Value = "New"
'Beginning of Tim's code
Dim ppt As Object, tbl As Object
Dim slide As Object, pres As Object, shp
Dim rngDest As Range
Set ppt = GetObject(, "Powerpoint.Application")
Set pres = ppt.ActivePresentation
Set rngDest = Sheets("Data").Range(B) 'Moved it over one column for formatting
For Each slide In pres.Slides
For Each shp In slide.Shapes
If shp.HasTable Then
ExtractTableContent shp.Table, rngDest
Set rngDest = rngDest.Offset(shp.Table.Rows.Count + 3, 0)
End If
Next
Next
ppts.ActivePresentation.Close 'Close PPT and loop for next one
FileName = Dir
Loop
End Sub
'More of Tim's code
Sub ExtractTableContent(oTable As Object, rng As Range)
Dim r, c, offR As Long, offC As Long
For Each r In oTable.Rows '<< Loop over each row in the PPT table
offC = 0 '<< reset the column offset
For Each c In r.Cells '<< Loop over each cell in the row
'Copy the cell's text content to Excel, using the offsets
' offR and offC to select where it gets placed relative
' to the starting point (rng)
rng.Offset(offR, offC).Value = c.Shape.TextFrame.TextRange.Text
offC = offC + 1 '<< increment the column offset
Next c
offR = offR + 1 '<< increment the row offset
Next r
End Sub
Sub N()
Range("A3").Value = "New" 'Simply adds "New" next to each new file opened. Helps for deliniation between files
End Sub