使用VBA将Powerpoint信息迁移到Access数据库

时间：2017-07-25 15:04:02

标签： vba excel-vba csv ms-access powerpoint

我正在与一家大型公司实习，该公司以PowerPoints的形式存储了大量的源数据。这些PowerPpoints在跨部门和供应商之间进行通信时很有用，但正如您可能猜测的那样，缺乏可靠的分析。因此，我决定将这些Powerpoint数据库编入Access。

我知道，没有直接的方法可以做到这一点。由于严格的IT策略，我仅限于VBA作为我的编码平台。我花了最后一周编写一个宏来解决我的问题。同样，由于没有PowerPoint直接转换为Access，我不得不相当低效地解决这个问题，因为有一些警告。我将在下面列出我的步骤和注意事项。

  1. 我想要数据库的powerpoint信息被格式化为表而不是文本。我一直无法找到将PPT表直接转换为Excel或CSV文件的宏。因此，我会将所有PPT文件（大约3000个）转换为PDF格式。

  2. 从这些生成的PDF中我可以使用Adobe将它们转换为Excel或CSV文件。

  3. 使用多个在线资源和我自己的一些经验，我编写了一个VBA脚本，该脚本会自动将CSV文件的文件格式化为Access将正确存储的格式。见代码1.

    • （“Personal.xlsb！Module1.FormatAccess”是一个主要使用“Record Macro”创建的宏。由于其长度和冗余，我省略了此代码。）

  4. 格式化CSV后，我会将它们全部自动化为Access。

  5. 在Access自动化之后，我需要将每个PPT文件嵌入其各自的Access条目

    6. 同样，这不是一个有效的过程。因为我仅限于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

    End Sub

    修改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

2 个答案:

答案 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
相关问题
最新问题