【发布时间】：2017-12-31 14:30:03
【问题描述】：
我在一家以 PowerPoint 形式存储大量源数据的大公司实习。这些 PowerPpoint 在跨部门和供应商之间进行沟通时效果很好，但正如您可能猜到的那样，它们缺乏任何可靠的分析。因此，我决定将这些 Powerpoints 数据库化到 Access 中。
据我所知，没有直接的方法可以做到这一点。由于严格的 IT 政策，我仅限于使用 VBA 作为我的编码平台。上周我已经编写了一个宏来解决我的问题。同样，由于没有将 PowerPoint 直接转换为 Access，我不得不以相当低效的方式解决这个问题，因为有一些警告。我将在下面列出我的步骤和注意事项。
我想要数据库的 powerpoint 信息被格式化为表格而不是文本。我一直无法找到将 PPT 表格直接转换为 Excel 或 CSV 文件的宏。因此，我会将所有 PPT 文件（大约 3000 个）转换为 PDF。
从这些生成的 PDF 中，我可以使用 Adobe 将它们转换为 Excel 或 CSV 文件。
-
使用多个在线资源和一些我自己的经验，我编写了一个 VBA 脚本，它会自动将 CSV 文件的文件夹格式化为 Access 可以正确存储的格式。参见代码 1。
- （“Personal.xlsb!Module1.FormatAccess”是一个主要使用“记录宏”创建的宏。由于它的长度和冗余，我省略了此代码。）
格式化 CSV 后，我会将它们全部自动化到 Access。
在 Access 自动化之后，我需要将每个 PPT 文件嵌入到其各自的 Access 条目中
同样，这不是一个有效的过程。因为我仅限于 Microsoft 应用程序，所以我选择了这条路线。我曾考虑将信息保留为 Excel 文件，但其想法是让任何部门都可以访问和搜索这些数据，因此我选择 Access 来对它们进行数据库化。
现在我已经向您解释了我来自哪里以及我在做什么，我问：您对我有什么建议？我觉得我的迂回方式是一个很好的解决方案，也很实用，但我想知道是否有更好的解决方案。
代码 1
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
结束子
编辑 1
在尝试了 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
编辑 2
我能够在 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
【问题讨论】：
-
在迁移数据时，我永远不会使用 PDF 作为中间格式：它不是为此而设计的。更可靠的方法是识别每个 Powerpoint 文件中的表格并直接提取数据。例如。这篇文章有一个可以用来开始的方法：stackoverflow.com/questions/4675100/…
-
嗨，蒂姆，谢谢你的评论。我最初是从那个帖子开始的，忘记在上面提到我需要提取的 PPT 幻灯片是表格，而不是文本格式。鉴于：“sh.HasTextFrame”没有解决我幻灯片的 table 属性，你知道可以解决这个问题的函数吗？而且因为这是一个表格而不是文本，我不能只做一个简单的复制/粘贴宏：P
-
pptfaq.com/FAQ00790_Working_with_PowerPoint_tables.htm 展示了如何处理 PPT 表格中单个单元格的内容。获得对表对象的引用后，您可以循环遍历行和列以提取数据（例如到 Excel，或直接到 Access）
-
谢谢！我会尝试一下并更新我的进度。
-
在最后一次编辑中，您正在创建多个 PPT 实例（在循环中使用
New PowerPoint.Application）。您不需要这样做：只需在进入循环之前创建一个实例，并在完成后关闭它。
标签： vba excel csv ms-access powerpoint