pdfminer3k在pdf中提取文本_ExcelVBA_034 Excel从Word文本中提取信息

一、需求说明

     现有word文档若干，每个文档内有不同项目的计划，如图所示

为了能够更直观地在Excel表格中能够一览所有项目的信息，需要把项目计划信息提取到excel表格中。最终结果如图所示

二、实现思路

        由于word文档中项目计划各项信息很有规律，因此可以借助正则表达式来提取。

三、实现代码

Public Sub Basic_CodeFrame()    '作者  DG-NextSeven    'QQ   84857038    '日期  2019年3月23日    '说明                                                                  '声明 过程中需要使用到的变量    Dim Wb As Workbook    Dim data_Sht As Worksheet    Dim ini_Sht As Worksheet    Dim row, col, i, dic As Object    Dim filepath, folderpath, filefilter    Dim wdApp, wdDoc                                                                    '连接当前工作簿    Set Wb = Application.ThisWorkbook                    '当前工作簿所在文件夹路径    folderpath = Wb.Path & "\"                    'word文档文件格式过滤    filefilter = "*.doc*"    '查找word文档,保存到数组中    filepaths = GetFiles(folderpath, filefilter)                    '能查找到word文档才继续    If Not IsEmpty(filepaths) Then                                                                                                                                                                                                                                                                                                                                               Dim Regex, Mhs, mh As Object                                    Set Regex = CreateObject("VBScript.RegExp") '创建正则表达式实例        With Regex            .Global = True '匹配所有符合条件文本            .Pattern = "^.*?项目名称：(.*?)$\r\n?^项目概况：(.*?)$\r\n?^工程范围：(.*?)$\r\n?^计价模式：" & _            "(.*?)$\r\n?^招标模式：(.*?)$\r\n?^评标方法：(.*?)$\r\n?^项目工期：(.*?)$\r\n?^参与竞标单位：(.*?)$\r\n?^本周完成：(.*?)$\r\n?^下周工作：(.*?)$"            .MultiLine = True '多行模式        End With                                                                                                                                                                                                                         '2获取数据        Set data_Sht = Wb.Worksheets("数据")        '仅保留表头，清除其他数据        data_Sht.UsedRange.Offset(1).Clear        '创建一个word应用程序对象        Set wdApp = CreateObject("Word.Application")        '循环所有文档        i = 1        For Each filepath In filepaths            '打开指定路径的word文档            Set wdDoc = wdApp.documents.Open(filepath)                                                            If Regex.test(wdDoc.Content.Text) Then                Set Mhs = Regex.Execute(wdDoc.Content.Text)                'RegGet = Mh.Item(0).submatches(0)                For Each mh In Mhs                    i = i + 1 '输出行号                    data_Sht.Cells(i, 1).Value = i - 1 '序号等于行号减去1                    For j = 0 To mh.submatches.Count - 1                        data_Sht.Cells(i, j + 2).Value = mh.submatches(j)                    Next j                Next mh            End If                                                                                                                     '关闭word文档，不保存更改            wdDoc.Close False        Next filepath '下一个word文档                                                                                           '退出word应用程序        wdApp.Quit                                                                                                           End If                                    '释放对象    Set wdApp = Nothing    Set wdDoc = Nothing    Set Wb = Nothing    Set data_Sht = Nothing    Set dic = Nothing    Set Regex = Nothing    Set Mhs = Nothing    Set mh = Nothing    End Sub'根据指定的文件夹路径和过滤字符，获得文件路径数组Function GetFiles(ByVal folderpath As String, ByVal filefiter As String) As String()    Dim filename As String, filepaths() As String    Dim n As Integer    ReDim filepaths(1 To 1)    filename = Dir(folderpath & filefiter)    Do While filename <> ""        n = n + 1        ReDim Preserve filepaths(1 To n)        filepaths(n) = folderpath & filename        filename = Dir    Loop    GetFiles = filepathsEnd Function

四、说明

    正则表达式是一强大的文本处理工具，也是学习文本处理需要跨过的一道坎，可以独立成为一门课。这里不作更多说明。

五、附件下载地址

链接：https://pan.baidu.com/s/1IDhYtasBRpKzsnjMXYYwlg

提取码：6pwj